Example #1
0
File: tcltk.c Project: kmillar/rho
static SEXP makeRTclObject(Tcl_Obj *tclobj)
{
    SEXP obj;

    PROTECT(obj = R_MakeExternalPtr(tclobj, R_NilValue, R_NilValue));
    Tcl_IncrRefCount(tclobj);
    R_RegisterCFinalizer(obj, RTcl_dec_refcount);
    UNPROTECT(1);
    return obj;
}
Example #2
0
File: tclFCmd.c Project: smh377/tcl
static Tcl_Obj *
FileBasename(
    Tcl_Interp *interp,		/* Interp, for error return. */
    Tcl_Obj *pathPtr)		/* Path whose basename to extract. */
{
    int objc;
    Tcl_Obj *splitPtr;
    Tcl_Obj *resultPtr = NULL;

    splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
    Tcl_IncrRefCount(splitPtr);

    if (objc != 0) {
	if ((objc == 1) && (*TclGetString(pathPtr) == '~')) {
	    Tcl_DecrRefCount(splitPtr);
	    if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
		return NULL;
	    }
	    splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
	    Tcl_IncrRefCount(splitPtr);
	}

	/*
	 * Return the last component, unless it is the only component, and it
	 * is the root of an absolute path.
	 */

	if (objc > 0) {
	    Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr);
	    if ((objc == 1) &&
		    (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
		resultPtr = NULL;
	    }
	}
    }
    if (resultPtr == NULL) {
	resultPtr = Tcl_NewObj();
    }
    Tcl_IncrRefCount(resultPtr);
    Tcl_DecrRefCount(splitPtr);
    return resultPtr;
}
Example #3
0
/* attach_connection DBCONN */
static int AttachConnectionObjCmd(void *clientdata,
                                  Tcl_Interp *interp,
                                  int objc,
                                  Tcl_Obj * const *objv)
{
    VTableInterpContext *vticP = (VTableInterpContext *)clientdata;
    VTableDB *vtdbP;
    sqlite3 *sqliteP;
    int new_entry;

    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 1, objv, " DBCONN");
        return TCL_ERROR;
    }

    /* Map the db connection command to the connection pointer */
    if (GetSqliteConnPtr(interp, Tcl_GetString(objv[1]), &sqliteP) != TCL_OK)
        return TCL_ERROR;

    /* Check if already registered the virtual table module for this conn. */
    
    if (Tcl_FindHashEntry(&vticP->dbconns, sqliteP) != NULL)
        return TCL_OK;

    /* Need to register for this db conn */
    vtdbP = VTDBNew();
    Tcl_IncrRefCount(objv[1]);
    vtdbP->dbcmd_objP = objv[1];

    /* Find out the NULL value representation this DB is using */
    if (InitNullValueForDB(interp, vtdbP)) {
        VTDBUnref(vtdbP, 1);
        return TCL_ERROR;
    }

    if (sqlite3_create_module_v2(sqliteP, PACKAGE_NAME, &sqlite_vtable_methods,
                                 vtdbP, VTDBDetachSqliteCallback)
        != SQLITE_OK) {
        VTDBUnref(vtdbP, 1);
        return ReturnSqliteError(interp, sqliteP, NULL);
    }
    
    /* Now add to the table of connections for this interpreter */
    Tcl_SetHashValue(Tcl_CreateHashEntry(&vticP->dbconns, sqliteP, &new_entry),
                     vtdbP);

    /* Link up various structures */
    vtdbP->sqliteP = sqliteP;
    vtdbP->vticP = vticP;
    VTICRef(vticP, 1); /* Since dbP refers to it. TBD - circular dependency? */
    VTDBRef(vtdbP, 2); /* Hash table ref + ref from sqlite */
    
    return TCL_OK;
}
Example #4
0
static VTableDB *VTDBNew(void)
{
    VTableDB *vtdbP = (VTableDB *) ckalloc(sizeof(*vtdbP));
    vtdbP->sqliteP = NULL;
    vtdbP->vticP = NULL;
    vtdbP->dbcmd_objP = NULL;
    vtdbP->null_objP = Tcl_NewObj();
    Tcl_IncrRefCount(vtdbP->null_objP);
    vtdbP->nrefs = 0;
    return vtdbP;
}
Example #5
0
static Tcl_Obj*
rcBuildCmdList(ReflectingChannel* chan_, Tcl_Obj* cmd_)
{
  Tcl_Obj* vec = Tcl_DuplicateObj(chan_->_context);
  Tcl_IncrRefCount(vec);

  Tcl_ListObjAppendElement(chan_->_interp, vec, cmd_);
  Tcl_ListObjAppendElement(chan_->_interp, vec, chan_->_name);

  return vec; /* with refcount 1 */
}
Example #6
0
TnmSnmp*
TnmSnmpCreateSession(Tcl_Interp *interp, char type)
{
    TnmSnmp *session;
    const char *user;

    session = (TnmSnmp *) ckalloc(sizeof(TnmSnmp));
    memset((char *) session, 0, sizeof(TnmSnmp));

    session->interp = interp;
    session->maddr.sin_family = AF_INET;
    if (type == TNM_SNMP_GENERATOR || type == TNM_SNMP_NOTIFIER) {
       session->maddr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
    } else {
       session->maddr.sin_addr.s_addr = htonl(INADDR_ANY);
    }
    if (type == TNM_SNMP_LISTENER || type == TNM_SNMP_NOTIFIER) {
	session->maddr.sin_port = htons((unsigned short) TNM_SNMP_TRAPPORT);
    } else {
	session->maddr.sin_port = htons((unsigned short) TNM_SNMP_PORT);
    }
    session->version = TNM_SNMPv1;
    session->domain = TNM_SNMP_UDP_DOMAIN;
    session->type = type;
    session->community = Tcl_NewStringObj("public", 6);
    Tcl_IncrRefCount(session->community);
    session->context = Tcl_NewStringObj("", 0);
    Tcl_IncrRefCount(session->context);

    user = Tcl_GetVar2(interp, "tnm", "user", TCL_GLOBAL_ONLY);
    if (! user) {
	user = "initial";
    }
    session->user = Tcl_NewStringObj(user, (int) strlen(user));
    Tcl_IncrRefCount(session->user);
    session->engineID = Tcl_NewStringObj("", 0);
    Tcl_IncrRefCount(session->engineID);
    session->maxSize = TNM_SNMP_MAXSIZE;
    session->securityLevel = TNM_SNMP_AUTH_NONE | TNM_SNMP_PRIV_NONE;
    session->maxSize = TNM_SNMP_MAXSIZE;
    session->authPassWord = Tcl_NewStringObj("public", 6);
    Tcl_IncrRefCount(session->authPassWord);
    session->privPassWord = Tcl_NewStringObj("private", 6);
    Tcl_IncrRefCount(session->privPassWord);
    session->retries = TNM_SNMP_RETRIES;
    session->timeout = TNM_SNMP_TIMEOUT;
    session->window  = TNM_SNMP_WINDOW;
    session->delay   = TNM_SNMP_DELAY;
    session->tagList = Tcl_NewListObj(0, NULL);
    Tcl_IncrRefCount(session->tagList);

    TnmOidInit(&session->enterpriseOid);
    TnmOidFromString(&session->enterpriseOid, "1.3.6.1.4.1.1575");

    return session;
}
Example #7
0
static OSErr 
OpenLibraryResource(
    struct CFragInitBlock* initBlkPtr)
{
    /*
     * The 3.0 version of the Universal headers changed CFragInitBlock
     * to an opaque pointer type.  CFragSystem7InitBlock is now the
     * real pointer.
     */
     
#if !defined(UNIVERSAL_INTERFACES_VERSION) || (UNIVERSAL_INTERFACES_VERSION < 0x0300)
    struct CFragInitBlock *realInitBlkPtr = initBlkPtr;
#else 
    CFragSystem7InitBlock *realInitBlkPtr = (CFragSystem7InitBlock *) initBlkPtr;
#endif
    FSSpec* fileSpec = NULL;
    OSErr err = noErr;
    

    if (realInitBlkPtr->fragLocator.where == kDataForkCFragLocator) {
    	fileSpec = realInitBlkPtr->fragLocator.u.onDisk.fileSpec;
    } else if (realInitBlkPtr->fragLocator.where == kResourceCFragLocator) {
    	fileSpec = realInitBlkPtr->fragLocator.u.inSegs.fileSpec;
    } else {
    	err = resFNotFound;
    }

    /*
     * Open the resource fork for this library in read-only mode.  
     * This will make it the current res file, ahead of the 
     * application's own resources.
     */
    
    if (fileSpec != NULL) {
	ourResFile = FSpOpenResFile(fileSpec, fsRdPerm);
	if (ourResFile == kResFileNotOpened) {
	    err = ResError();
	} else {
#ifdef TCL_REGISTER_LIBRARY
	    ourResToken = Tcl_NewObj();
	    Tcl_IncrRefCount(ourResToken);
	    p2cstr(realInitBlkPtr->libName);
	    Tcl_SetStringObj(ourResToken, (char *) realInitBlkPtr->libName, -1);
	    c2pstr((char *) realInitBlkPtr->libName);
	    TclMacRegisterResourceFork(ourResFile, ourResToken,
	            TCL_RESOURCE_DONT_CLOSE);
#endif
            SetResFileAttrs(ourResFile, mapReadOnly);
	}
    }
    
    return err;
}
Example #8
0
TclObject &
TclObject::lappend (Tcl_Obj *pElement)
{
    if (Tcl_IsShared(m_pObj)) {
        Tcl_DecrRefCount(m_pObj);
        m_pObj = Tcl_DuplicateObj(m_pObj);
        Tcl_IncrRefCount(m_pObj);
    }
    Tcl_ListObjAppendElement(NULL, m_pObj, pElement);
    // TODO: Should check for error result if conversion to list failed.
    return *this;
}
Example #9
0
/*************************************************************************
* FUNCTION      :   RPMTransaction_Set::RPM_callback                     *
* ARGUMENTS     :   none                                                 *
* RETURNS       :   TCL_OK or TCL_ERROR                                  *
* EXCEPTIONS    :   none                                                 *
* PURPOSE       :   Set or get problem mask flags                        *
*************************************************************************/
void *RPMTransaction_Set::RPM_callback( const void * h,
                                        const rpmCallbackType what,
                                        const unsigned long amount,
                                        const unsigned long total,
                                        fnpyKey key
                                      )
{
    // Build up the list of call back bits
    Tcl_Obj *bitstring = Tcl_NewObj();
    for (unsigned i = 0; i < sizeof(bits)/sizeof(bits[0]); ++i)
    {
        if (what & bits[i].bit)
        {
            Tcl_ListObjAppendElement(_interp,bitstring,Tcl_NewStringObj(bits[i].msg,-1));
        }
    }
    RPMHeader_Obj *hdr = (RPMHeader_Obj *)key;
    Tcl_Obj *cmd[] =
    {
        Tcl_NewStringObj("::RPM::Callback",-1),
        bitstring,
        Tcl_NewLongObj(amount),
        Tcl_NewLongObj(total),
        hdr?hdr->Get_obj():Tcl_NewObj()
    };
    Tcl_Obj *script = Tcl_NewListObj(sizeof(cmd)/sizeof(cmd[0]),cmd);
    Tcl_IncrRefCount(script);
    Tcl_EvalObj(_interp,script);
    Tcl_DecrRefCount(script);

    // Now, handle any special operations here
    if (what & RPMCALLBACK_INST_OPEN_FILE)
    {
        assert(hdr);
        FD_t fd = hdr->Open();
        if (!fd || Ferror(fd))
        {
            if (fd)
            {
                Fclose(fd);
                fd = 0;
            }
        }
        return (void *)fd;
    }
    if (what & RPMCALLBACK_INST_CLOSE_FILE)
    {
        assert(hdr);
        hdr->Close();
        return 0;
    }
    return 0;
}
Example #10
0
/* assign a var from a var */
Tcl_Obj*
TSP_Util_lang_assign_var_var(Tcl_Obj* targetVarName, Tcl_Obj* sourceVarName) {
    if (targetVarName != NULL) {
        Tcl_DecrRefCount(targetVarName);
    }

    /* targetVarName = Tcl_DuplicateObj(sourceVarName);  */
    targetVarName = sourceVarName;

    Tcl_IncrRefCount(targetVarName);
    return targetVarName;
}
Example #11
0
int NS(SendEND_AND_CALLBACK) (NS_ARGS)
{
  SETUP_mqctx
  MQ_STR token;
  Tcl_Obj *callback;
  CHECK_C(token)
  CHECK_OBJ(callback)
  CHECK_NOARGS
  Tcl_IncrRefCount(callback);
  ErrorMqToTclWithCheck(MqSendEND_AND_CALLBACK(mqctx, token, NS(ProcCall), callback, NS(ProcFree)));
  RETURN_TCL
}
Example #12
0
File: tclf.c Project: nektomk/tcl-f
static int
resolveTypes(Tcl_Interp *interp) {
	Tcl_Obj *objv[6];
	Tcl_Obj *list;
	Tcl_Obj *dict;
	// определение типа lambdaExpr
	objv[0]=Tcl_NewStringObj("apply",-1); 
	objv[1]=Tcl_NewStringObj("x { expr $x + 1}",-1);
	objv[2]=Tcl_NewIntObj(1),-1;
	Tcl_IncrRefCount(objv[0]);
	Tcl_IncrRefCount(objv[1]);
	Tcl_IncrRefCount(objv[2]);
	if (Tcl_EvalObjv(interp,3,objv,0)!=TCL_OK) {
		ERR("in call apply");
		INSPECT_ARRAY(-1,3,objv,"command");
		return TCL_ERROR;
	}
	cmdNameType=objv[0]->typePtr;
	lambdaExprType=objv[1]->typePtr;
	// определение типа List
	
	list=Tcl_NewListObj(3,objv);
	listType=list->typePtr;
	if (listType==NULL || listType->name==NULL || listType->name[0]=='\0') {
		ERR("in resolve listType");
		return TCL_ERROR;
	}
	Tcl_DecrRefCount(list);
	Tcl_DecrRefCount(objv[0]);
	Tcl_DecrRefCount(objv[1]);
	Tcl_DecrRefCount(objv[2]);
	// определение типа dict
	dict=Tcl_NewDictObj();
	if (dict==NULL || dict->typePtr==NULL) {
		ERR("in resolve dictType");
		return TCL_ERROR;
	}
	dictType=dict->typePtr;
	return TCL_OK;
}
Example #13
0
/* + style configure $style -option ?value...
 */
static int StyleConfigureCmd(
    ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
{
    StylePackageData *pkgPtr = clientData;
    Ttk_Theme theme = pkgPtr->currentTheme;
    const char *styleName;
    Style *stylePtr;
    int i;

    if (objc < 3) {
usage:
	Tcl_WrongNumArgs(interp,2,objv,"style ?-option ?value...??");
	return TCL_ERROR;
    }

    styleName = Tcl_GetString(objv[2]);
    stylePtr = Ttk_GetStyle(theme, styleName);

    if (objc == 3) {		/* style default $styleName */
	Tcl_SetObjResult(interp, HashTableToDict(&stylePtr->defaultsTable));
	return TCL_OK;
    } else if (objc == 4) {	/* style default $styleName -option */
	const char *optionName = Tcl_GetString(objv[3]);
	Tcl_HashEntry *entryPtr =
	    Tcl_FindHashEntry(&stylePtr->defaultsTable, optionName);
	if (entryPtr) {
	    Tcl_SetObjResult(interp, (Tcl_Obj*)Tcl_GetHashValue(entryPtr));
	}
	return TCL_OK;
    } else if (objc % 2 != 1) {
	goto usage;
    }

    for (i = 3; i < objc; i += 2) {
	const char *optionName = Tcl_GetString(objv[i]);
	Tcl_Obj *value = objv[i+1];
	Tcl_HashEntry *entryPtr;
	int newEntry;

	entryPtr = Tcl_CreateHashEntry(
		&stylePtr->defaultsTable,optionName,&newEntry);

	Tcl_IncrRefCount(value);
	if (!newEntry) {
	    Tcl_DecrRefCount((Tcl_Obj*)Tcl_GetHashValue(entryPtr));
	}
	Tcl_SetHashValue(entryPtr, value);
    }

    ThemeChanged(pkgPtr);
    return TCL_OK;
}
Example #14
0
static int
Ta4r_PackageInit (Tcl_Interp *interp) {
	Tcl_Namespace *ns;
	Ta4r_Cmd *c;
	Tcl_Obj *o;
	Tcl_Obj *m;
	Tcl_Obj *f;

	if ((ns = Tcl_FindNamespace(interp, Ta4r, NULL, TCL_LEAVE_ERR_MSG)) == NULL) { return TCL_ERROR; }

	m = Tcl_NewDictObj();
	for (c = &Ta4r_Cmds[0]; c->name != NULL; c++) {
		/* Put commands into sub-namespace so as not to conflict with ensemble name */
		/* This will also create the sub-namespace. Slightly cheap? */
		o = Tcl_ObjPrintf("%s::commands::%s", Ta4r, c->name);
		Tcl_IncrRefCount(o);
		f = Tcl_ObjPrintf("::tcl::mathfunc::%s", c->name);
		Tcl_IncrRefCount(f);
		if (Tcl_CreateObjCommand(interp, Tcl_GetString(o), c->proc, NULL, NULL) == NULL) {
			Tcl_DecrRefCount(o);
			Tcl_DecrRefCount(f);
			return TCL_ERROR;
		}
		if (Tcl_CreateAlias(interp, Tcl_GetString(f), interp, Tcl_GetString(o), 0, NULL) != TCL_OK) {
			Tcl_DecrRefCount(o);
			Tcl_DecrRefCount(f);
			return TCL_ERROR;
		}
		Tcl_DictObjPut(interp, m, Tcl_NewStringObj(c->name+4, -1), o);
		Tcl_DecrRefCount(o);
		Tcl_DecrRefCount(f);
	}
	if (Tcl_SetEnsembleMappingDict(interp,
		Tcl_CreateEnsemble(interp, (Ta4r+2), ns, TCL_ENSEMBLE_PREFIX), m) != TCL_OK) { return TCL_ERROR; };

	if (Tcl_Export(interp, ns, (Ta4r+2), 0) != TCL_OK) { return TCL_ERROR; }

	return TCL_OK;
}
Example #15
0
static void
SetVarToObj(
    int varIndex,		/* Designates the assignment variable. */
    Tcl_Obj *objPtr)		/* Points to object to assign to var. */
{
    if (varPtr[varIndex] != NULL) {
	Tcl_DecrRefCount(varPtr[varIndex]);
    }
    varPtr[varIndex] = objPtr;
    if (objPtr != NULL) {
	Tcl_IncrRefCount(objPtr);
    }
}
Example #16
0
/*
 * ------------------------------------------------------------------------
 *  AddClassUnknowMethod()
 *
 * ------------------------------------------------------------------------
 */
static int
AddClassUnknowMethod(
    Tcl_Interp *interp,
    ItclObjectInfo *infoPtr,
    Tcl_Class clsPtr)
{
    ClientData tmPtr, pmPtr;

    infoPtr->unknownNamePtr = Tcl_NewStringObj("unknown", -1);
    Tcl_IncrRefCount(infoPtr->unknownNamePtr);
    infoPtr->unknownArgumentPtr = Tcl_NewStringObj("m args", -1);
    Tcl_IncrRefCount(infoPtr->unknownArgumentPtr);
    infoPtr->unknownBodyPtr = Tcl_NewStringObj(clazzUnknownBody, -1);
    Tcl_IncrRefCount(infoPtr->unknownBodyPtr);
    tmPtr = (ClientData)Itcl_NewProcClassMethod(interp,
        clsPtr, NULL, NULL, NULL, NULL, infoPtr->unknownNamePtr,
	infoPtr->unknownArgumentPtr, infoPtr->unknownBodyPtr, &pmPtr);
    if (tmPtr == NULL) {
        Tcl_Panic("cannot add class method unknown");
    }
    return TCL_OK;
}
Example #17
0
stf_status tpm_call_out(const char *name
			, struct state *st
			, struct connection *conn
			, struct msg_digest *md)
{
    Tcl_Obj  **objv;
    int   objc=0, ret;
    char *res;
    Tcl_Obj *to;

    passert(name != NULL);

    objv = alloc_bytes(sizeof(Tcl_Obj *)*4, "tcl objv");
    objv[0]=Tcl_NewStringObj(name, -1);
    objv[1]=tpm_StateToInstanceObj(st);
    objv[2]=tpm_ConnectionToInstanceObj(conn);
    objv[3]=tpm_MessageDigestToInstanceObj(md);
    Tcl_IncrRefCount(objv[0]);
    Tcl_IncrRefCount(objv[1]);
    Tcl_IncrRefCount(objv[2]);
    Tcl_IncrRefCount(objv[3]);

    objc=4;

    ret = tpm_call_it(objv, objc);

    while(objc > 0) {
	objc--;
	if(objv[objc]!=NULL) {
	    Tcl_DecrRefCount(objv[objc]);
	    objv[objc]=NULL;
	}
    }
    pfree(objv);

    passert(name != NULL);

    return ret;
}
Example #18
0
static void
CheckbuttonInitialize(Tcl_Interp *interp, void *recordPtr)
{
    Checkbutton *checkPtr = recordPtr;
    Tcl_Obj *variableObj;

    /* default -variable is the widget name:
     */
    variableObj = Tcl_NewStringObj(Tk_PathName(checkPtr->core.tkwin), -1);
    Tcl_IncrRefCount(variableObj);
    checkPtr->checkbutton.variableObj = variableObj;
    BaseInitialize(interp, recordPtr);
}
Example #19
0
static int InitNullValueForDB(Tcl_Interp *interp, VTableDB *vtdbP)
{
    Tcl_Obj *objv[2];
    int status;

    objv[0] = vtdbP->dbcmd_objP; /* No need to IncrRef this as vtdbP
                                    already ensures that */
    objv[1] = Tcl_NewStringObj("nullvalue", -1);
    Tcl_IncrRefCount(objv[1]);

    status = Tcl_EvalObjv(interp, 2, objv, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL);
    Tcl_DecrRefCount(objv[1]);

    if (status == TCL_ERROR)
        return TCL_ERROR;

    if (vtdbP->null_objP)
        Tcl_DecrRefCount(vtdbP->null_objP);
    vtdbP->null_objP = Tcl_GetObjResult(interp);
    Tcl_IncrRefCount(vtdbP->null_objP);
    return TCL_OK;
}
Example #20
0
static void tvfsExecTcl(
  Testvfs *p, 
  const char *zMethod,
  Tcl_Obj *arg1,
  Tcl_Obj *arg2,
  Tcl_Obj *arg3
){
  int rc;                         /* Return code from Tcl_EvalObj() */
  int nArg;                       /* Elements in eval'd list */
  int nScript;
  Tcl_Obj ** ap;

  assert( p->pScript );

  if( !p->apScript ){
    int nByte;
    int i;
    if( TCL_OK!=Tcl_ListObjGetElements(p->interp, p->pScript, &nScript, &ap) ){
      Tcl_BackgroundError(p->interp);
      Tcl_ResetResult(p->interp);
      return;
    }
    p->nScript = nScript;
    nByte = (nScript+TESTVFS_MAX_ARGS)*sizeof(Tcl_Obj *);
    p->apScript = (Tcl_Obj **)ckalloc(nByte);
    memset(p->apScript, 0, nByte);
    for(i=0; i<nScript; i++){
      p->apScript[i] = ap[i];
    }
  }

  p->apScript[p->nScript] = Tcl_NewStringObj(zMethod, -1);
  p->apScript[p->nScript+1] = arg1;
  p->apScript[p->nScript+2] = arg2;
  p->apScript[p->nScript+3] = arg3;

  for(nArg=p->nScript; p->apScript[nArg]; nArg++){
    Tcl_IncrRefCount(p->apScript[nArg]);
  }

  rc = Tcl_EvalObjv(p->interp, nArg, p->apScript, TCL_EVAL_GLOBAL);
  if( rc!=TCL_OK ){
    Tcl_BackgroundError(p->interp);
    Tcl_ResetResult(p->interp);
  }

  for(nArg=p->nScript; p->apScript[nArg]; nArg++){
    Tcl_DecrRefCount(p->apScript[nArg]);
    p->apScript[nArg] = 0;
  }
}
Example #21
0
File: tkConsole.c Project: tcltk/tk
static int
ConsoleOutput(
    ClientData instanceData,	/* Indicates which device to use. */
    const char *buf,		/* The data buffer. */
    int toWrite,		/* How many bytes to write? */
    int *errorCode)		/* Where to store error code. */
{
    ChannelData *data = instanceData;
    ConsoleInfo *info = data->info;

    *errorCode = 0;
    Tcl_SetErrno(0);

    if (info) {
	Tcl_Interp *consoleInterp = info->consoleInterp;

	if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) {
	    Tcl_DString ds;
	    Tcl_Encoding utf8 = Tcl_GetEncoding(NULL, "utf-8");

	    /*
	     * Not checking for utf8 == NULL.  Did not check for TCL_ERROR
	     * from Tcl_SetChannelOption() in Tk_InitConsoleChannels() either.
	     * Assumption is utf-8 Tcl_Encoding is reliably present.
	     */

	    const char *bytes
		    = Tcl_ExternalToUtfDString(utf8, buf, toWrite, &ds);
	    int numBytes = Tcl_DStringLength(&ds);
	    Tcl_Obj *cmd = Tcl_NewStringObj("tk::ConsoleOutput", -1);

	    Tcl_FreeEncoding(utf8);

	    if (data->type == TCL_STDERR) {
		Tcl_ListObjAppendElement(NULL, cmd,
			Tcl_NewStringObj("stderr", -1));
	    } else {
		Tcl_ListObjAppendElement(NULL, cmd,
			Tcl_NewStringObj("stdout", -1));
	    }
	    Tcl_ListObjAppendElement(NULL, cmd,
		    Tcl_NewStringObj(bytes, numBytes));

	    Tcl_DStringFree(&ds);
	    Tcl_IncrRefCount(cmd);
	    Tcl_EvalObjEx(consoleInterp, cmd, TCL_EVAL_GLOBAL);
	    Tcl_DecrRefCount(cmd);
	}
    }
    return toWrite;
}
Example #22
0
/*
** This is the callback from a quota-over-limit.
*/
static void tclQuotaCallback(
  const char *zFilename,          /* Name of file whose size increases */
  sqlite3_int64 *piLimit,         /* IN/OUT: The current limit */
  sqlite3_int64 iSize,            /* Total size of all files in the group */
  void *pArg                      /* Client data */
){
  TclQuotaCallback *p;            /* Callback script object */
  Tcl_Obj *pEval;                 /* Script to evaluate */
  Tcl_Obj *pVarname;              /* Name of variable to pass as 2nd arg */
  unsigned int rnd;               /* Random part of pVarname */
  int rc;                         /* Tcl error code */

  p = (TclQuotaCallback *)pArg;
  if( p==0 ) return;

  pVarname = Tcl_NewStringObj("::piLimit_", -1);
  Tcl_IncrRefCount(pVarname);
  sqlite3_randomness(sizeof(rnd), (void *)&rnd);
  Tcl_AppendObjToObj(pVarname, Tcl_NewIntObj((int)(rnd&0x7FFFFFFF)));
  Tcl_ObjSetVar2(p->interp, pVarname, 0, Tcl_NewWideIntObj(*piLimit), 0);

  pEval = Tcl_DuplicateObj(p->pScript);
  Tcl_IncrRefCount(pEval);
  Tcl_ListObjAppendElement(0, pEval, Tcl_NewStringObj(zFilename, -1));
  Tcl_ListObjAppendElement(0, pEval, pVarname);
  Tcl_ListObjAppendElement(0, pEval, Tcl_NewWideIntObj(iSize));
  rc = Tcl_EvalObjEx(p->interp, pEval, TCL_EVAL_GLOBAL);

  if( rc==TCL_OK ){
    Tcl_Obj *pLimit = Tcl_ObjGetVar2(p->interp, pVarname, 0, 0);
    rc = Tcl_GetWideIntFromObj(p->interp, pLimit, piLimit);
    Tcl_UnsetVar(p->interp, Tcl_GetString(pVarname), 0);
  }

  Tcl_DecrRefCount(pEval);
  Tcl_DecrRefCount(pVarname);
  if( rc!=TCL_OK ) Tcl_BackgroundError(p->interp);
}
Example #23
0
ClientData
TclNativeCreateNativeRep(
    Tcl_Obj *pathPtr)
{
    char *nativePathPtr;
    const char *str;
    Tcl_DString ds;
    Tcl_Obj *validPathPtr;
    size_t len;

    if (TclFSCwdIsNative()) {
	/*
	 * The cwd is native, which means we can use the translated path
	 * without worrying about normalization (this will also usually be
	 * shorter so the utf-to-external conversion will be somewhat faster).
	 */

	validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
	if (validPathPtr == NULL) {
	    return NULL;
	}
    } else {
	/*
	 * Make sure the normalized path is set.
	 */

	validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	if (validPathPtr == NULL) {
	    return NULL;
	}
	Tcl_IncrRefCount(validPathPtr);
    }

    str = TclGetString(validPathPtr);
    len = validPathPtr->length;
    Tcl_UtfToExternalDString(NULL, str, len, &ds);
    len = Tcl_DStringLength(&ds) + sizeof(char);
    if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) {
	/* See bug [3118489]: NUL in filenames */
	Tcl_DecrRefCount(validPathPtr);
	Tcl_DStringFree(&ds);
	return NULL;
    }
    Tcl_DecrRefCount(validPathPtr);
    nativePathPtr = ckalloc(len);
    memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len);

    Tcl_DStringFree(&ds);
    return nativePathPtr;
}
Example #24
0
static Tcl_Obj *
GetConfigDict(
    Tcl_Interp *interp)
{
    Tcl_Obj *pDB = Tcl_GetAssocData(interp, ASSOC_KEY, NULL);

    if (pDB == NULL) {
	pDB = Tcl_NewDictObj();
	Tcl_IncrRefCount(pDB);
	Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB);
    }

    return pDB;
}
Example #25
0
File: tclf.c Project: nektomk/tcl-f
static int
resolveCommands(Tcl_Interp *interp,struct CommandEntry *table)
{
	struct CommandEntry *entry;
	if (table==NULL) return TCL_ERROR;
	for(entry=table+0;entry->name!=NULL;entry++) {
		entry->nameObj=Tcl_NewStringObj(entry->name,-1);
		Tcl_IncrRefCount(entry->nameObj);
		entry->token=Tcl_GetCommandFromObj(interp,entry->nameObj);
		if (entry->token==NULL) {
			ERR("Unresolved %s",entry->name);
			return TCL_ERROR;
		}
		if (entry->saveNamePtr!=NULL) {
			*entry->saveNamePtr=entry->nameObj;
			Tcl_IncrRefCount(entry->nameObj);
		}
		if (entry->saveTokenPtr!=NULL) {
			*entry->saveTokenPtr=entry->token;
		}
	}
	return TCL_OK;
}
Example #26
0
//
// Return a list of ctable quote type names (cache it, too)
//
CTABLE_INTERNAL Tcl_Obj *ctable_quoteTypeList(Tcl_Interp *interp)
{
    static Tcl_Obj *result = NULL;

    if (!result) {
        int index;
	result = Tcl_NewObj();
        for(index = 0; ctable_quote_names[index]; index++) {
	    Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj(ctable_quote_names[index], -1));
	}
	Tcl_IncrRefCount(result);
    }
    return result;
}
Example #27
0
stf_status tpm_call_out_crypt(const char *name
			      , struct state *st
			      , pb_stream *pbs, int off, int len)
{
    Tcl_Obj  **objv;
    int   objc=0, ret;
    char *res;
    Tcl_Obj *to;

    objv = alloc_bytes(sizeof(Tcl_Obj *)*5, "tcl objv");
    objv[0]=Tcl_NewStringObj(name, -1);

    objv[1]=tpm_StateToInstanceObj(st);
    objv[2]=tpm_PbStreamToInstanceObj(pbs);
    objv[3]=Tcl_NewIntObj(off);
    objv[4]=Tcl_NewIntObj(len);
    Tcl_IncrRefCount(objv[0]);
    Tcl_IncrRefCount(objv[1]);
    Tcl_IncrRefCount(objv[2]);
    Tcl_IncrRefCount(objv[3]);
    Tcl_IncrRefCount(objv[4]);

    objc=5;

    ret = tpm_call_it(objv, objc);

    while(objc > 0) {
	objc--;
	if(objv[objc]!=NULL) {
	    Tcl_DecrRefCount(objv[objc]);
	    objv[objc]=NULL;
	}
    }
    pfree(objv);

    return ret;
}
Example #28
0
/*
 *---------------------------------------------------------------------------
 *
 * HtmlImagePixmap --
 *
 * Results:
 *     Pixmap. Or zero.
 *
 * Side effects:
 *     May change the image storage to pixmap.
 *
 *---------------------------------------------------------------------------
 */
Pixmap
HtmlImagePixmap(HtmlImage2 *pImage)
{
    if (!pImage->pImageServer->pTree->options.imagepixmapify ||
        !pImage->pImageName ||
        !getImageCompressed(pImage) ||
        pImage->width<=0 ||
        pImage->height<=0
    ) {
        return 0;
    }
    if (!pImage->isValid) {
        HtmlImageImage(pImage);
    }
    if (!pImage->pixmap && !HtmlImageAlphaChannel(pImage)) {
        Tk_Window win = pImage->pImageServer->pTree->tkwin;
        Tcl_Interp *interp = pImage->pImageServer->pTree->interp;

        Pixmap pix;
        int rc;
        Tcl_Obj *pGetData;

#if 0
printf("Pixmapifying - nData = %d\n", nData);
#endif

        pix = Tk_GetPixmap(Tk_Display(win), Tk_WindowId(win),
            pImage->width, pImage->height, Tk_Depth(win)
        );
        Tk_RedrawImage(
            pImage->image, 0, 0, pImage->width, pImage->height, pix, 0, 0
        );

        pImage->pixmap = pix;

        pGetData = Tcl_NewObj();
        Tcl_IncrRefCount(pGetData);
        Tcl_ListObjAppendElement(0, pGetData, Tcl_NewStringObj("image",-1));
        Tcl_ListObjAppendElement(0, pGetData, Tcl_NewStringObj("create",-1));
        Tcl_ListObjAppendElement(0, pGetData, Tcl_NewStringObj("photo",-1));
        Tcl_ListObjAppendElement(0, pGetData, pImage->pImageName);
        pImage->nIgnoreChange++;
        rc = Tcl_EvalObjEx(interp, pGetData, TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT);
        pImage->nIgnoreChange--;
        Tcl_DecrRefCount(pGetData);
        assert(rc==TCL_OK);
    }
    return pImage->pixmap;
}
Example #29
0
stf_status tpm_call_out_notify(const char *name
			       , struct state *st
			       , pb_stream *pbs
			       , struct isakmp_hdr *hdr)
{
    Tcl_Obj  **objv;
    int   objc=0, ret;
    char *res;
    Tcl_Obj *to;

    objv = alloc_bytes(sizeof(Tcl_Obj *)*4, "tcl objv");
    objv[0]=Tcl_NewStringObj(name, -1);

    objv[1]=tpm_StateToInstanceObj(st);
    objv[2]=tpm_PbStreamToInstanceObj(pbs);
    objv[3]=tpm_IsakmpHdrToInstanceObj(hdr);
    Tcl_IncrRefCount(objv[0]);
    Tcl_IncrRefCount(objv[1]);
    Tcl_IncrRefCount(objv[2]);
    Tcl_IncrRefCount(objv[3]);

    objc=4;

    ret = tpm_call_it(objv, objc);

    while(objc > 0) {
	objc--;
	if(objv[objc]!=NULL) {
	    Tcl_DecrRefCount(objv[objc]);
	    objv[objc]=NULL;
	}
    }
    pfree(objv);

    return ret;
}
Example #30
0
static int tclvarFilter(
  sqlite3_vtab_cursor *pVtabCursor, 
  int idxNum, const char *idxStr,
  int argc, sqlite3_value **argv
){
  tclvar_cursor *pCur = (tclvar_cursor *)pVtabCursor;
  Tcl_Interp *interp = ((tclvar_vtab *)(pVtabCursor->pVtab))->interp;

  Tcl_Obj *p = Tcl_NewStringObj("info vars", -1);
  Tcl_IncrRefCount(p);

  assert( argc==0 || argc==1 );
  if( argc==1 ){
    Tcl_Obj *pArg = Tcl_NewStringObj((char*)sqlite3_value_text(argv[0]), -1);
    Tcl_ListObjAppendElement(0, p, pArg);
  }
  Tcl_EvalObjEx(interp, p, TCL_EVAL_GLOBAL);
  pCur->pList1 = Tcl_GetObjResult(interp);
  Tcl_IncrRefCount(pCur->pList1);
  assert( pCur->i1==0 && pCur->i2==0 && pCur->pList2==0 );

  Tcl_DecrRefCount(p);
  return tclvarNext(pVtabCursor);
}