static int TestobjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int varIndex, destIndex, i; char *index, *subCmd, *string; Tcl_ObjType *targetType; if (objc < 2) { wrongNumArgs: Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); return TCL_ERROR; } subCmd = Tcl_GetString(objv[1]); if (strcmp(subCmd, "assign") == 0) { if (objc != 4) { goto wrongNumArgs; } index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } string = Tcl_GetString(objv[3]); if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { return TCL_ERROR; } SetVarToObj(destIndex, varPtr[varIndex]); Tcl_SetObjResult(interp, varPtr[destIndex]); } else if (strcmp(subCmd, "convert") == 0) { char *typeName; if (objc != 4) { goto wrongNumArgs; } index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } typeName = Tcl_GetString(objv[3]); if ((targetType = Tcl_GetObjType(typeName)) == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "no type ", typeName, " found", NULL); return TCL_ERROR; } if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) != TCL_OK) { return TCL_ERROR; } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "duplicate") == 0) { if (objc != 4) { goto wrongNumArgs; } index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } string = Tcl_GetString(objv[3]); if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { return TCL_ERROR; } SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex])); Tcl_SetObjResult(interp, varPtr[destIndex]); } else if (strcmp(subCmd, "freeallvars") == 0) { if (objc != 2) { goto wrongNumArgs; } for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { if (varPtr[i] != NULL) { Tcl_DecrRefCount(varPtr[i]); varPtr[i] = NULL; } } } else if ( strcmp ( subCmd, "invalidateStringRep" ) == 0 ) { if ( objc != 3 ) { goto wrongNumArgs; } index = Tcl_GetString( objv[2] ); if ( GetVariableIndex( interp, index, &varIndex ) != TCL_OK ) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } Tcl_InvalidateStringRep( varPtr[varIndex] ); Tcl_SetObjResult( interp, varPtr[varIndex] ); } else if (strcmp(subCmd, "newobj") == 0) { if (objc != 3) { goto wrongNumArgs; } index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } SetVarToObj(varIndex, Tcl_NewObj()); Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "objtype") == 0) { const char *typeName; /* * return an object containing the name of the argument's type * of internal rep. If none exists, return "none". */ if (objc != 3) { goto wrongNumArgs; } if (objv[2]->typePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); } else { typeName = objv[2]->typePtr->name; Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); } } else if (strcmp(subCmd, "refcount") == 0) { char buf[TCL_INTEGER_SPACE]; if (objc != 3) { goto wrongNumArgs; } index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } TclFormatInt(buf, varPtr[varIndex]->refCount); Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if (strcmp(subCmd, "type") == 0) { if (objc != 3) { goto wrongNumArgs; } index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); } else { Tcl_AppendToObj(Tcl_GetObjResult(interp), varPtr[varIndex]->typePtr->name, -1); } } else if (strcmp(subCmd, "types") == 0) { if (objc != 2) { goto wrongNumArgs; } if (Tcl_AppendAllObjTypes(interp, Tcl_GetObjResult(interp)) != TCL_OK) { return TCL_ERROR; } } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", Tcl_GetString(objv[1]), "\": must be assign, convert, duplicate, freeallvars, " "newobj, objcount, objtype, refcount, type, or types", NULL); return TCL_ERROR; } return TCL_OK; }
Tcl_Obj* TclpObjLink( Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction) { if (toPtr != NULL) { CONST char *src = Tcl_FSGetNativePath(pathPtr); CONST char *target = NULL; if (src == NULL) { return NULL; } /* * If we're making a symbolic link and the path is relative, then we * must check whether it exists _relative_ to the directory in which * the src is found (not relative to the current cwd which is just not * relevant in this case). * * If we're making a hard link, then a relative path is just converted * to absolute relative to the cwd. */ if ((linkAction & TCL_CREATE_SYMBOLIC_LINK) && (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) { Tcl_Obj *dirPtr, *absPtr; dirPtr = TclPathPart(NULL, pathPtr, TCL_PATH_DIRNAME); if (dirPtr == NULL) { return NULL; } absPtr = Tcl_FSJoinToPath(dirPtr, 1, &toPtr); Tcl_IncrRefCount(absPtr); if (Tcl_FSAccess(absPtr, F_OK) == -1) { Tcl_DecrRefCount(absPtr); Tcl_DecrRefCount(dirPtr); /* * Target doesn't exist. */ errno = ENOENT; return NULL; } /* * Target exists; we'll construct the relative path we want below. */ Tcl_DecrRefCount(absPtr); Tcl_DecrRefCount(dirPtr); } else { target = Tcl_FSGetNativePath(toPtr); if (target == NULL) { return NULL; } if (access(target, F_OK) == -1) { /* * Target doesn't exist. */ errno = ENOENT; return NULL; } } if (access(src, F_OK) != -1) { /* * Src exists. */ errno = EEXIST; return NULL; } /* * Check symbolic link flag first, since we prefer to create these. */ if (linkAction & TCL_CREATE_SYMBOLIC_LINK) { int targetLen; Tcl_DString ds; Tcl_Obj *transPtr; /* * Now we don't want to link to the absolute, normalized path. * Relative links are quite acceptable (but links to ~user are not * -- these must be expanded first). */ transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr); if (transPtr == NULL) { return NULL; } target = Tcl_GetStringFromObj(transPtr, &targetLen); target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds); Tcl_DecrRefCount(transPtr); if (symlink(target, src) != 0) { toPtr = NULL; } Tcl_DStringFree(&ds); } else if (linkAction & TCL_CREATE_HARD_LINK) { if (link(target, src) != 0) { return NULL; } } else { errno = ENODEV; return NULL; } return toPtr; } else { Tcl_Obj *linkPtr = NULL; char link[MAXPATHLEN]; int length; Tcl_DString ds; Tcl_Obj *transPtr; transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); if (transPtr == NULL) { return NULL; } Tcl_DecrRefCount(transPtr); length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link)); if (length < 0) { return NULL; } Tcl_ExternalToUtfDString(NULL, link, length, &ds); linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); if (linkPtr != NULL) { Tcl_IncrRefCount(linkPtr); } return linkPtr; } }
/* ** Open an tvfs file handle. */ static int tvfsOpen( sqlite3_vfs *pVfs, const char *zName, sqlite3_file *pFile, int flags, int *pOutFlags ){ int rc; TestvfsFile *pTestfile = (TestvfsFile *)pFile; TestvfsFd *pFd; Tcl_Obj *pId = 0; Testvfs *p = (Testvfs *)pVfs->pAppData; pFd = (TestvfsFd *)ckalloc(sizeof(TestvfsFd) + PARENTVFS(pVfs)->szOsFile); memset(pFd, 0, sizeof(TestvfsFd) + PARENTVFS(pVfs)->szOsFile); pFd->pShm = 0; pFd->pShmId = 0; pFd->zFilename = zName; pFd->pVfs = pVfs; pFd->pReal = (sqlite3_file *)&pFd[1]; memset(pTestfile, 0, sizeof(TestvfsFile)); pTestfile->pFd = pFd; /* Evaluate the Tcl script: ** ** SCRIPT xOpen FILENAME KEY-VALUE-ARGS ** ** If the script returns an SQLite error code other than SQLITE_OK, an ** error is returned to the caller. If it returns SQLITE_OK, the new ** connection is named "anon". Otherwise, the value returned by the ** script is used as the connection name. */ Tcl_ResetResult(p->interp); if( p->pScript && p->mask&TESTVFS_OPEN_MASK ){ Tcl_Obj *pArg = Tcl_NewObj(); Tcl_IncrRefCount(pArg); if( flags&SQLITE_OPEN_MAIN_DB ){ const char *z = &zName[strlen(zName)+1]; while( *z ){ Tcl_ListObjAppendElement(0, pArg, Tcl_NewStringObj(z, -1)); z += strlen(z) + 1; Tcl_ListObjAppendElement(0, pArg, Tcl_NewStringObj(z, -1)); z += strlen(z) + 1; } } tvfsExecTcl(p, "xOpen", Tcl_NewStringObj(pFd->zFilename, -1), pArg, 0, 0); Tcl_DecrRefCount(pArg); if( tvfsResultCode(p, &rc) ){ if( rc!=SQLITE_OK ) return rc; }else{ pId = Tcl_GetObjResult(p->interp); } } if( (p->mask&TESTVFS_OPEN_MASK) && tvfsInjectIoerr(p) ) return SQLITE_IOERR; if( tvfsInjectCantopenerr(p) ) return SQLITE_CANTOPEN; if( tvfsInjectFullerr(p) ) return SQLITE_FULL; if( !pId ){ pId = Tcl_NewStringObj("anon", -1); } Tcl_IncrRefCount(pId); pFd->pShmId = pId; Tcl_ResetResult(p->interp); rc = sqlite3OsOpen(PARENTVFS(pVfs), zName, pFd->pReal, flags, pOutFlags); if( pFd->pReal->pMethods ){ sqlite3_io_methods *pMethods; int nByte; if( pVfs->iVersion>1 ){ nByte = sizeof(sqlite3_io_methods); }else{ nByte = offsetof(sqlite3_io_methods, xShmMap); } pMethods = (sqlite3_io_methods *)ckalloc(nByte); memcpy(pMethods, &tvfs_io_methods, nByte); pMethods->iVersion = pFd->pReal->pMethods->iVersion; if( pMethods->iVersion>pVfs->iVersion ){ pMethods->iVersion = pVfs->iVersion; } if( pVfs->iVersion>1 && ((Testvfs *)pVfs->pAppData)->isNoshm ){ pMethods->xShmUnmap = 0; pMethods->xShmLock = 0; pMethods->xShmBarrier = 0; pMethods->xShmMap = 0; } pFile->pMethods = pMethods; } return rc; }
void TclpInitLibraryPath( char **valuePtr, int *lengthPtr, Tcl_Encoding *encodingPtr) { #define LIBRARY_SIZE 32 Tcl_Obj *pathPtr, *objPtr; CONST char *str; Tcl_DString buffer; pathPtr = Tcl_NewObj(); /* * Look for the library relative to the TCL_LIBRARY env variable. If the * last dirname in the TCL_LIBRARY path does not match the last dirname in * the installLib variable, use the last dir name of installLib in * addition to the orginal TCL_LIBRARY path. */ str = getenv("TCL_LIBRARY"); /* INTL: Native. */ Tcl_ExternalToUtfDString(NULL, str, -1, &buffer); str = Tcl_DStringValue(&buffer); if ((str != NULL) && (str[0] != '\0')) { Tcl_DString ds; int pathc; CONST char **pathv; char installLib[LIBRARY_SIZE]; Tcl_DStringInit(&ds); /* * Initialize the substrings used when locating an executable. The * installLib variable computes the path as though the executable is * installed. */ sprintf(installLib, "lib/tcl%s", TCL_VERSION); /* * If TCL_LIBRARY is set, search there. */ objPtr = Tcl_NewStringObj(str, -1); Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); Tcl_SplitPath(str, &pathc, &pathv); if ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc-1]) != 0)) { /* * If TCL_LIBRARY is set but refers to a different tcl * installation than the current version, try fiddling with the * specified directory to make it refer to this installation by * removing the old "tclX.Y" and substituting the current version * string. */ pathv[pathc - 1] = installLib + 4; str = Tcl_JoinPath(pathc, pathv, &ds); objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); Tcl_DStringFree(&ds); } ckfree((char *) pathv); } /* * Finally, look for the library relative to the compiled-in path. This is * needed when users install Tcl with an exec-prefix that is different * from the prefix. */ { #ifdef HAVE_COREFOUNDATION char tclLibPath[MAXPATHLEN + 1]; if (MacOSXGetLibraryPath(NULL, MAXPATHLEN, tclLibPath) == TCL_OK) { str = tclLibPath; } else #endif /* HAVE_COREFOUNDATION */ { /* * TODO: Pull this value from the TIP 59 table. */ str = defaultLibraryDir; } if (str[0] != '\0') { objPtr = Tcl_NewStringObj(str, -1); Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); } } Tcl_DStringFree(&buffer); *encodingPtr = Tcl_GetEncoding(NULL, NULL); str = Tcl_GetStringFromObj(pathPtr, lengthPtr); *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1); memcpy(*valuePtr, str, (size_t)(*lengthPtr)+1); Tcl_DecrRefCount(pathPtr); }
/************************************************************************* * FUNCTION : RPMTransaction_Set::ProbFlags * * ARGUMENTS : none * * RETURNS : TCL_OK or TCL_ERROR * * EXCEPTIONS : none * * PURPOSE : Set or get problem mask flags * *************************************************************************/ int RPMTransaction_Set::ProbFlags(Tcl_Interp *interp,int objc, Tcl_Obj *const objv[]) { if (objc >= 3) { // Build a list of indexes matching the packages given. Tcl_Obj *args = Tcl_NewListObj(objc-2,objv+2); if (!args) return Error("Cannot concat arglist!"); Tcl_IncrRefCount(args); // Iterate over list and build up the list unsigned mask = prob_flags; int count = 0; if (Tcl_ListObjLength(interp,args,&count) != TCL_OK) { parse_error: Tcl_DecrRefCount(args); return TCL_ERROR; } for (int i = 0; i < count; ++i) { Tcl_Obj *flag = 0; int which = 0; if (Tcl_ListObjIndex(interp,args,i,&flag) != TCL_OK) goto parse_error; if (Tcl_GetIndexFromObjStruct(interp,flag,(char **)&Prob_bits[0].msg,sizeof(Prob_bits[0]), "flag",0,&which ) != TCL_OK) goto parse_error; if (Prob_bits[which].bit == RPMPROB_FILTER_NONE ) mask = RPMPROB_FILTER_NONE; else mask |= Prob_bits[which].bit; } Tcl_DecrRefCount(args); prob_flags = mask; } // Now, build the return list Tcl_Obj *val = Tcl_NewObj(); Tcl_IncrRefCount(val); if (prob_flags == 0) { if (Tcl_ListObjAppendElement(interp,val,Tcl_NewStringObj(Prob_bits[0].msg,-1)) != TCL_OK) { out_err: Tcl_DecrRefCount(val); return TCL_ERROR; } } else if (prob_flags == (unsigned)(-1)) { if (Tcl_ListObjAppendElement(interp,val,Tcl_NewStringObj("all",-1)) != TCL_OK) { goto out_err; } } else { for (int i = 0; Prob_bits[i].msg; ++i) { if (Prob_bits[i].bit == (unsigned)(-1)) continue; if (prob_flags & Prob_bits[i].bit) { if (Tcl_ListObjAppendElement(interp,val,Tcl_NewStringObj(Prob_bits[i].msg,-1)) != TCL_OK) { Tcl_DecrRefCount(val); return TCL_ERROR; } } } } return OK(val); }
/* ARGSUSED */ static void StdinProc( ClientData clientData, /* The state of interactive cmd line */ int mask) /* Not used. */ { InteractiveState *isPtr = (InteractiveState *) clientData; Tcl_Channel chan = isPtr->input; Tcl_Obj *commandPtr = isPtr->commandPtr; Tcl_Interp *interp = isPtr->interp; int code, length; if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_DuplicateObj(commandPtr); Tcl_IncrRefCount(commandPtr); } length = Tcl_GetsObj(chan, commandPtr); if (length < 0) { if (Tcl_InputBlocked(chan)) { return; } if (isPtr->tty) { /* * Would be better to find a way to exit the mainLoop? Or perhaps * evaluate [exit]? Leaving as is for now due to compatibility * concerns. */ Tcl_Exit(0); } Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) isPtr); return; } if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_DuplicateObj(commandPtr); Tcl_IncrRefCount(commandPtr); } Tcl_AppendToObj(commandPtr, "\n", 1); if (!TclObjCommandComplete(commandPtr)) { isPtr->prompt = PROMPT_CONTINUE; goto prompt; } isPtr->prompt = PROMPT_START; Tcl_GetStringFromObj(commandPtr, &length); Tcl_SetObjLength(commandPtr, --length); /* * Disable the stdin channel handler while evaluating the command; * otherwise if the command re-enters the event loop we might process * commands from stdin before the current command is finished. Among other * things, this will trash the text of the command being evaluated. */ Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) isPtr); code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN); Tcl_DecrRefCount(commandPtr); isPtr->commandPtr = commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(commandPtr); if (chan != (Tcl_Channel) NULL) { Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, (ClientData) isPtr); } if (code != TCL_OK) { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel != (Tcl_Channel) NULL) { Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); Tcl_WriteChars(errChannel, "\n", 1); } } else if (isPtr->tty) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); Tcl_Channel outChannel = Tcl_GetStdChannel(TCL_STDOUT); Tcl_IncrRefCount(resultPtr); Tcl_GetStringFromObj(resultPtr, &length); if ((length >0) && (outChannel != (Tcl_Channel) NULL)) { Tcl_WriteObj(outChannel, resultPtr); Tcl_WriteChars(outChannel, "\n", 1); } Tcl_DecrRefCount(resultPtr); } /* * If a tty stdin is still around, output a prompt. */ prompt: if (isPtr->tty && (isPtr->input != (Tcl_Channel) NULL)) { Prompt(interp, &(isPtr->prompt)); isPtr->input = Tcl_GetStdChannel(TCL_STDIN); } }
Tk_Image HtmlImageImage(HtmlImage2 *pImage) { assert(pImage && (pImage->isValid == 1 || pImage->isValid == 0)); if (!pImage->isValid) { /* pImage->image is invalid. This happens if the underlying Tk * image, or the image that this is a scaled copy of, is changed * or deleted. It also happens the first time this function is * called after a call to HtmlImageScale(). */ Tk_PhotoHandle photo; Tk_PhotoImageBlock block; Tcl_Interp *interp = pImage->pImageServer->pTree->interp; HtmlImage2 *pUnscaled = pImage->pUnscaled; if (pUnscaled->pixmap) { Tcl_Obj *apObj[4]; int rc; /*printf("TODO: BAD. Have to recreate image to make scaled copy.\n");*/ apObj[0] = pUnscaled->pImageName; apObj[1] = Tcl_NewStringObj("configure", -1); apObj[2] = Tcl_NewStringObj("-data", -1); apObj[3] = pUnscaled->pCompressed; Tcl_IncrRefCount(apObj[1]); Tcl_IncrRefCount(apObj[2]); Tcl_IncrRefCount(apObj[3]); pUnscaled->nIgnoreChange++; rc = Tcl_EvalObjv(interp, 4, apObj, TCL_EVAL_GLOBAL); pUnscaled->nIgnoreChange--; assert(rc==TCL_OK); Tcl_IncrRefCount(apObj[3]); Tcl_DecrRefCount(apObj[2]); Tcl_DecrRefCount(apObj[1]); } assert(pUnscaled); if (!pImage->pImageName) { /* If pImageName is still NULL, then create a new photo * image to write the scaled data to. Todo: Is it possible * to do this without invoking a script, creating the Tcl * command etc.? */ Tk_Window win = pImage->pImageServer->pTree->tkwin; Tcl_Interp *interp = pImage->pImageServer->pTree->interp; const char *z; Tcl_Eval(interp, "image create photo"); pImage->pImageName = Tcl_GetObjResult(interp); Tcl_IncrRefCount(pImage->pImageName); assert(0 == pImage->pDelete); assert(0 == pImage->image); z = Tcl_GetString(pImage->pImageName); pImage->image = Tk_GetImage(interp, win, z, imageChanged, pImage); } assert(pImage->image); CHECK_INTEGER_PLAUSIBILITY(pImage->width); CHECK_INTEGER_PLAUSIBILITY(pImage->height); CHECK_INTEGER_PLAUSIBILITY(pUnscaled->width); CHECK_INTEGER_PLAUSIBILITY(pUnscaled->height); /* Write the scaled data into image pImage->image */ photo = Tk_FindPhoto(interp, Tcl_GetString(pUnscaled->pImageName)); if (photo) { Tk_PhotoGetImage(photo, &block); } if (photo && block.pixelPtr) { int x, y; /* Iterator variables */ int w, h; /* Width and height of unscaled image */ int sw, sh; /* Width and height of scaled image */ Tk_PhotoHandle s_photo; Tk_PhotoImageBlock s_block; sw = pImage->width; sh = pImage->height; w = pUnscaled->width; h = pUnscaled->height; s_photo = Tk_FindPhoto(interp, Tcl_GetString(pImage->pImageName)); s_block.pixelPtr = (unsigned char *)HtmlAlloc("temp", sw * sh * 4); s_block.width = sw; s_block.height = sh; s_block.pitch = sw * 4; s_block.pixelSize = 4; s_block.offset[0] = 0; s_block.offset[1] = 1; s_block.offset[2] = 2; s_block.offset[3] = 3; for (x=0; x<sw; x++) { int orig_x = ((x * w) / sw); for (y=0; y<sh; y++) { unsigned char *zOrig; unsigned char *zScale; int orig_y = ((y * h) / sh); zOrig = &block.pixelPtr[ orig_x * block.pixelSize + orig_y * block.pitch]; zScale = &s_block.pixelPtr[ x * s_block.pixelSize + y * s_block.pitch]; zScale[0] = zOrig[block.offset[0]]; zScale[1] = zOrig[block.offset[1]]; zScale[2] = zOrig[block.offset[2]]; zScale[3] = zOrig[block.offset[3]]; } } photoputblock(interp, s_photo, &s_block, 0, 0, sw, sh, 0); HtmlFree(s_block.pixelPtr); } else { return HtmlImageImage(pImage->pUnscaled); } pImage->isValid = 1; if (pUnscaled->pixmap) { Tcl_Obj *apObj[4]; apObj[0] = Tcl_NewStringObj("image", -1); apObj[1] = Tcl_NewStringObj("create", -1); apObj[2] = Tcl_NewStringObj("photo", -1); apObj[3] = pUnscaled->pImageName; Tcl_IncrRefCount(apObj[0]); Tcl_IncrRefCount(apObj[1]); Tcl_IncrRefCount(apObj[2]); pUnscaled->nIgnoreChange++; Tcl_EvalObjv(interp, 4, apObj, TCL_EVAL_GLOBAL); pUnscaled->nIgnoreChange--; Tcl_DecrRefCount(apObj[2]); Tcl_DecrRefCount(apObj[1]); Tcl_IncrRefCount(apObj[0]); } } return pImage->image; }
void ics_tcl_handler(struct ics_server *ics, struct ics_trigger *trig, struct ics_data *data) { int ret; Tcl_Obj *command; Tcl_Obj *ics_label; Tcl_Obj *who; Tcl_Obj *action; Tcl_Obj *message; Tcl_Obj *sender; Tcl_Obj *game_id; Tcl_Obj *white; Tcl_Obj *black; Tcl_Obj *winner; Tcl_Obj *loser; Tcl_Obj *result; Tcl_Obj *style12; Tcl_Obj *initial_time; Tcl_Obj *time_increment; Tcl_Obj **objv; char *hackpad; size_t hackpad_len; switch (trig->type) { /* alecmao(U) tells you: hi */ case ICS_TRIG_TELL: command = Tcl_NewStringObj(trig->command, strlen(trig->command)); ics_label = Tcl_NewStringObj(ics->label, strlen(ics->label)); for (hackpad_len=0; data->tokens[0][hackpad_len] != '\0' && data->tokens[0][hackpad_len] != '('; hackpad_len++); hackpad = tmalloc0(hackpad_len + 1); strncpy(hackpad, data->tokens[0], hackpad_len); sender = Tcl_NewStringObj(hackpad, strlen(hackpad)); hackpad = &data->txt_packet[strlen(data->tokens[0]) + strlen(data->tokens[1]) + strlen(data->tokens[2]) + 3]; message = Tcl_NewStringObj(hackpad, strlen(hackpad)); Tcl_IncrRefCount(command); Tcl_IncrRefCount(ics_label); Tcl_IncrRefCount(sender); Tcl_IncrRefCount(message); objv = tmalloc(sizeof(Tcl_Obj *) * 4); objv[0] = command; objv[1] = ics_label; objv[2] = sender; objv[3] = message; ret = Tcl_EvalObjv(ics->tclinterp, 4, objv, TCL_EVAL_GLOBAL); /* Decrement the reference count so the GC will catch it */ Tcl_DecrRefCount(command); Tcl_DecrRefCount(ics_label); Tcl_DecrRefCount(sender); Tcl_DecrRefCount(message); /* If we returned an error, send it to trollbot's warning channel */ if (ret == TCL_ERROR) { troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(ics->tclinterp)); } free(objv); break; /* <ICS Label> <game id> <white> <black> <winner> <loser> <result> <message> */ case ICS_TRIG_ENDGAME: command = Tcl_NewStringObj(trig->command, strlen(trig->command)); ics_label = Tcl_NewStringObj(ics->label, strlen(ics->label)); game_id = Tcl_NewIntObj(ics->game->game_number); white = Tcl_NewStringObj(ics->game->white_name, strlen(ics->game->white_name)); black = Tcl_NewStringObj(ics->game->black_name, strlen(ics->game->black_name)); winner = Tcl_NewStringObj(ics->game->winner_name, strlen(ics->game->winner_name)); loser = Tcl_NewStringObj(ics->game->loser_name, strlen(ics->game->loser_name)); result = Tcl_NewStringObj(ics->game->end_result, strlen(ics->game->end_result)); message = Tcl_NewStringObj(ics->game->end_message, strlen(ics->game->end_message)); Tcl_IncrRefCount(command); Tcl_IncrRefCount(ics_label); Tcl_IncrRefCount(game_id); Tcl_IncrRefCount(white); Tcl_IncrRefCount(black); Tcl_IncrRefCount(winner); Tcl_IncrRefCount(loser); Tcl_IncrRefCount(result); Tcl_IncrRefCount(message); objv = tmalloc(sizeof(Tcl_Obj *) * 9); objv[0] = command; objv[1] = ics_label; objv[2] = game_id; objv[3] = white; objv[4] = black; objv[5] = winner; objv[6] = loser; objv[7] = result; objv[8] = message; ret = Tcl_EvalObjv(ics->tclinterp, 9, objv, TCL_EVAL_GLOBAL); /* Decrement the reference count so the GC will catch it */ Tcl_DecrRefCount(command); Tcl_DecrRefCount(ics_label); Tcl_DecrRefCount(game_id); Tcl_DecrRefCount(white); Tcl_DecrRefCount(black); Tcl_DecrRefCount(winner); Tcl_DecrRefCount(loser); Tcl_DecrRefCount(result); Tcl_DecrRefCount(message); /* If we returned an error, send it to trollbot's warning channel */ if (ret == TCL_ERROR) { troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(ics->tclinterp)); } free(objv); break; /* <ICS Label> <game id> <white> <black> <initial time> <time increment> */ case ICS_TRIG_GAME: /* The proper way of doing things, according to #tcl on freenode (they'd know) */ command = Tcl_NewStringObj(trig->command, strlen(trig->command)); ics_label = Tcl_NewStringObj(ics->label, strlen(ics->label)); game_id = Tcl_NewIntObj(ics->game->game_number); white = Tcl_NewStringObj(ics->game->white_name, strlen(ics->game->white_name)); black = Tcl_NewStringObj(ics->game->black_name, strlen(ics->game->black_name)); initial_time = Tcl_NewIntObj(ics->game->initial_time); time_increment = Tcl_NewIntObj(ics->game->increment_time); Tcl_IncrRefCount(command); Tcl_IncrRefCount(ics_label); Tcl_IncrRefCount(game_id); Tcl_IncrRefCount(white); Tcl_IncrRefCount(black); Tcl_IncrRefCount(initial_time); Tcl_IncrRefCount(time_increment); objv = tmalloc(sizeof(Tcl_Obj *) * 7); objv[0] = command; objv[1] = ics_label; objv[2] = game_id; objv[3] = white; objv[4] = black; objv[5] = initial_time; objv[6] = time_increment; /* Call <command> <nick> <uhost> <hand> <chan> <arg> */ ret = Tcl_EvalObjv(ics->tclinterp, 7, objv, TCL_EVAL_GLOBAL); /* Decrement the reference count so the GC will catch it */ Tcl_DecrRefCount(command); Tcl_DecrRefCount(ics_label); Tcl_DecrRefCount(game_id); Tcl_DecrRefCount(white); Tcl_DecrRefCount(black); Tcl_DecrRefCount(initial_time); Tcl_DecrRefCount(time_increment); /* If we returned an error, send it to trollbot's warning channel */ if (ret == TCL_ERROR) { troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(ics->tclinterp)); } free(objv); break; /* <ICS Label> <Message> */ case ICS_TRIG_MSG: /* The proper way of doing things, according to #tcl on freenode (they'd know) */ command = Tcl_NewStringObj(trig->command, strlen(trig->command)); ics_label = Tcl_NewStringObj(ics->label, strlen(ics->label)); message = Tcl_NewStringObj(data->txt_packet, strlen(data->txt_packet)); Tcl_IncrRefCount(command); Tcl_IncrRefCount(ics_label); Tcl_IncrRefCount(message); objv = tmalloc(sizeof(Tcl_Obj *) * 3); objv[0] = command; objv[1] = ics_label; objv[2] = message; /* Call <command> <nick> <uhost> <hand> <chan> <arg> */ ret = Tcl_EvalObjv(ics->tclinterp, 3, objv, TCL_EVAL_GLOBAL); /* Decrement the reference count so the GC will catch it */ Tcl_DecrRefCount(command); Tcl_DecrRefCount(ics_label); Tcl_DecrRefCount(message); /* If we returned an error, send it to trollbot's warning channel */ if (ret == TCL_ERROR) { troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(ics->tclinterp)); } free(objv); break; case ICS_TRIG_CONNECT: /* The proper way of doing things, according to #tcl on freenode (they'd know) */ command = Tcl_NewStringObj(trig->command, strlen(trig->command)); ics_label = Tcl_NewStringObj(ics->label, strlen(ics->label)); who = Tcl_NewStringObj(data->tokens[1], strlen(data->tokens[1])); Tcl_IncrRefCount(command); Tcl_IncrRefCount(ics_label); Tcl_IncrRefCount(who); objv = tmalloc(sizeof(Tcl_Obj *) * 3); objv[0] = command; objv[1] = ics_label; objv[2] = who; /* Call <command> <nick> <uhost> <hand> <chan> <arg> */ ret = Tcl_EvalObjv(ics->tclinterp, 3, objv, TCL_EVAL_GLOBAL); /* Decrement the reference count so the GC will catch it */ Tcl_DecrRefCount(command); Tcl_DecrRefCount(ics_label); Tcl_DecrRefCount(who); /* If we returned an error, send it to trollbot's warning channel */ if (ret == TCL_ERROR) { troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(ics->tclinterp)); } free(objv); break; case ICS_TRIG_MOVE: command = Tcl_NewStringObj(trig->command, strlen(trig->command)); ics_label = Tcl_NewStringObj(ics->label, strlen(ics->label)); style12 = Tcl_NewStringObj(ics->game->style_twelve, strlen(ics->game->style_twelve)); Tcl_IncrRefCount(command); Tcl_IncrRefCount(ics_label); Tcl_IncrRefCount(style12); /* I don't need a NULL last array element */ objv = tmalloc(sizeof(Tcl_Obj *) * 3); objv[0] = command; objv[1] = ics_label; objv[2] = style12; /* Call <command> <nick> <uhost> <hand> <chan> <arg> */ ret = Tcl_EvalObjv(ics->tclinterp, 3, objv, TCL_EVAL_GLOBAL); /* Decrement the reference count so the GC will catch it */ Tcl_DecrRefCount(command); Tcl_DecrRefCount(ics_label); Tcl_DecrRefCount(style12); /* If we returned an error, send it to trollbot's warning channel */ if (ret == TCL_ERROR) { troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(ics->tclinterp)); } free(objv); break; case ICS_TRIG_NOTIFY: /* The proper way of doing things, according to #tcl on freenode (they'd know) */ command = Tcl_NewStringObj(trig->command, strlen(trig->command)); ics_label = Tcl_NewStringObj(ics->label, strlen(ics->label)); who = Tcl_NewStringObj(data->tokens[1], strlen(data->tokens[1])); action = Tcl_NewStringObj(data->tokens[3], strlen(data->tokens[3])); /* We need to increase the reference count, because if TCL suddenly gets some * time for GC, it will notice a zero reference count */ Tcl_IncrRefCount(command); Tcl_IncrRefCount(ics_label); Tcl_IncrRefCount(who); Tcl_IncrRefCount(action); /* I don't need a NULL last array element */ objv = tmalloc(sizeof(Tcl_Obj *) * 4); objv[0] = command; objv[1] = ics_label; objv[2] = who; objv[3] = action; /* Call <command> <nick> <uhost> <hand> <chan> <arg> */ ret = Tcl_EvalObjv(ics->tclinterp, 4, objv, TCL_EVAL_GLOBAL); /* Decrement the reference count so the GC will catch it */ Tcl_DecrRefCount(command); Tcl_DecrRefCount(ics_label); Tcl_DecrRefCount(who); Tcl_DecrRefCount(action); /* If we returned an error, send it to trollbot's warning channel */ if (ret == TCL_ERROR) { troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(ics->tclinterp)); } free(objv); break; } return; }
/* ARGSUSED */ int Tcl_OpenObjCmd( ClientData notUsed, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int pipeline, prot; const char *modeString, *what; Tcl_Channel chan; if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?"); return TCL_ERROR; } prot = 0666; if (objc == 2) { modeString = "r"; } else { modeString = TclGetString(objv[2]); if (objc == 4) { char *permString = TclGetString(objv[3]); int code = TCL_ERROR; int scanned = TclParseAllWhiteSpace(permString, -1); /* Support legacy octal numbers */ if ((permString[scanned] == '0') && (permString[scanned+1] >= '0') && (permString[scanned+1] <= '7')) { Tcl_Obj *permObj; TclNewLiteralStringObj(permObj, "0o"); Tcl_AppendToObj(permObj, permString+scanned+1, -1); code = TclGetIntFromObj(NULL, permObj, &prot); Tcl_DecrRefCount(permObj); } if ((code == TCL_ERROR) && TclGetIntFromObj(interp, objv[3], &prot) != TCL_OK) { return TCL_ERROR; } } } pipeline = 0; what = TclGetString(objv[1]); if (what[0] == '|') { pipeline = 1; } /* * Open the file or create a process pipeline. */ if (!pipeline) { chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); } else { int mode, seekFlag, cmdObjc, binary; const char **cmdArgv; if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { return TCL_ERROR; } mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); if (mode == -1) { chan = NULL; } else { int flags = TCL_STDERR | TCL_ENFORCE_MODE; switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { case O_RDONLY: flags |= TCL_STDOUT; break; case O_WRONLY: flags |= TCL_STDIN; break; case O_RDWR: flags |= (TCL_STDIN | TCL_STDOUT); break; default: Tcl_Panic("Tcl_OpenCmd: invalid mode value"); break; } chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags); if (binary) { Tcl_SetChannelOption(interp, chan, "-translation", "binary"); } } ckfree((char *) cmdArgv); } if (chan == NULL) { return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); return TCL_OK; }
void TkMakeRawCurvePostscript( Tcl_Interp *interp, /* Interpreter in whose result the Postscript * is to be stored. */ Tk_Canvas canvas, /* Canvas widget for which the Postscript is * being generated. */ double *pointPtr, /* Array of input coordinates: x0, y0, x1, y1, * etc.. */ int numPoints) /* Number of points at pointPtr. */ { int i; double *segPtr; Tcl_Obj *psObj; /* * Put the first point into the path. */ psObj = Tcl_ObjPrintf("%.15g %.15g moveto\n", pointPtr[0], Tk_CanvasPsY(canvas, pointPtr[1])); /* * Loop through all the remaining points in the curve, generating a * straight line or curve section for every three of them. */ for (i=numPoints-1,segPtr=pointPtr ; i>=3 ; i-=3,segPtr+=6) { if (segPtr[0]==segPtr[2] && segPtr[1]==segPtr[3] && segPtr[4]==segPtr[6] && segPtr[5]==segPtr[7]) { /* * The control points on this segment are equal to their * neighbouring knots, so this segment is just a straight line. */ Tcl_AppendPrintfToObj(psObj, "%.15g %.15g lineto\n", segPtr[6], Tk_CanvasPsY(canvas, segPtr[7])); } else { /* * This is a generic Bezier curve segment. */ Tcl_AppendPrintfToObj(psObj, "%.15g %.15g %.15g %.15g %.15g %.15g curveto\n", segPtr[2], Tk_CanvasPsY(canvas, segPtr[3]), segPtr[4], Tk_CanvasPsY(canvas, segPtr[5]), segPtr[6], Tk_CanvasPsY(canvas, segPtr[7])); } } /* * If there are any points left that haven't been used, then build the * last segment and generate Postscript in the same way for that. */ if (i > 0) { int j; double control[8]; for (j=0; j<2*i+2; j++) { control[j] = segPtr[j]; } for (; j<8; j++) { control[j] = pointPtr[j-2*i-2]; } if (control[0]==control[2] && control[1]==control[3] && control[4]==control[6] && control[5]==control[7]) { /* * Straight line. */ Tcl_AppendPrintfToObj(psObj, "%.15g %.15g lineto\n", control[6], Tk_CanvasPsY(canvas, control[7])); } else { /* * Bezier curve segment. */ Tcl_AppendPrintfToObj(psObj, "%.15g %.15g %.15g %.15g %.15g %.15g curveto\n", control[2], Tk_CanvasPsY(canvas, control[3]), control[4], Tk_CanvasPsY(canvas, control[5]), control[6], Tk_CanvasPsY(canvas, control[7])); } } Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj); Tcl_DecrRefCount(psObj); }
/* This handles all triggers which have a handler of tcl, or was set that way through * a bind in a TCL script. * * Rewritten to use the proper way, instead of doing that Tcl_ValEval() garbage. */ void tcl_handler(struct network *net, struct trigger *trig, struct irc_data *data, struct dcc_session *dcc, const char *dccbuf) { int ret; char *my_arg; Tcl_Obj *command; Tcl_Obj *nick; Tcl_Obj *uhost; Tcl_Obj *hand; Tcl_Obj *chan; Tcl_Obj *arg; Tcl_Obj *msg; Tcl_Obj *from; Tcl_Obj *keyword; Tcl_Obj *text; Tcl_Obj **objv; switch (trig->type) { case TRIG_PUB: /* The proper way of doing things, according to #tcl on freenode (they'd know) */ command = Tcl_NewStringObj(trig->command, strlen(trig->command)); nick = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick)); uhost = Tcl_NewStringObj(data->prefix->host, strlen(data->prefix->host)); hand = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick)); chan = Tcl_NewStringObj(data->c_params[0], strlen(data->c_params[0])); /* We do this because I'm retarded and have no way of figuring out what should happen after the mask */ my_arg = tstrdup(troll_makearg(data->rest_str,trig->mask)); arg = Tcl_NewStringObj(my_arg, strlen(my_arg)); /* We need to increase the reference count, because if TCL suddenly gets some * time for GC, it will notice a zero reference count */ Tcl_IncrRefCount(command); Tcl_IncrRefCount(nick); Tcl_IncrRefCount(uhost); Tcl_IncrRefCount(hand); Tcl_IncrRefCount(chan); Tcl_IncrRefCount(arg); /* I don't need a NULL last array element */ objv = tmalloc(sizeof(Tcl_Obj *) * 6); objv[0] = command; objv[1] = nick; objv[2] = uhost; objv[3] = hand; objv[4] = chan; objv[5] = arg; /* Call <command> <nick> <uhost> <hand> <chan> <arg> */ ret = Tcl_EvalObjv(net->tclinterp, 6, objv, TCL_EVAL_GLOBAL); /* Decrement the reference count so the GC will catch it */ Tcl_DecrRefCount(command); Tcl_DecrRefCount(nick); Tcl_DecrRefCount(uhost); Tcl_DecrRefCount(hand); Tcl_DecrRefCount(chan); Tcl_DecrRefCount(arg); /* If we returned an error, send it to trollbot's warning channel */ if (ret == TCL_ERROR) { troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp)); } free(my_arg); free(objv); break; case TRIG_PUBM: /* The proper way of doing things, according to #tcl on freenode (they'd know) */ command = Tcl_NewStringObj(trig->command, strlen(trig->command)); nick = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick)); uhost = Tcl_NewStringObj(data->prefix->host, strlen(data->prefix->host)); hand = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick)); chan = Tcl_NewStringObj(data->c_params[0], strlen(data->c_params[0])); text = Tcl_NewStringObj(data->rest_str, strlen(data->rest_str)); /* We need to increase the reference count, because if TCL suddenly gets some * time for GC, it will notice a zero reference count */ Tcl_IncrRefCount(command); Tcl_IncrRefCount(nick); Tcl_IncrRefCount(uhost); Tcl_IncrRefCount(hand); Tcl_IncrRefCount(chan); Tcl_IncrRefCount(text); /* I don't need a NULL last array element */ objv = tmalloc(sizeof(Tcl_Obj *) * 6); objv[0] = command; objv[1] = nick; objv[2] = uhost; objv[3] = hand; objv[4] = chan; objv[5] = text; /* Call <command> <nick> <uhost> <hand> <chan> <arg> */ ret = Tcl_EvalObjv(net->tclinterp, 6, objv, TCL_EVAL_GLOBAL); /* Decrement the reference count so the GC will catch it */ Tcl_DecrRefCount(command); Tcl_DecrRefCount(nick); Tcl_DecrRefCount(uhost); Tcl_DecrRefCount(hand); Tcl_DecrRefCount(chan); Tcl_DecrRefCount(text); /* If we returned an error, send it to trollbot's warning channel */ if (ret == TCL_ERROR) { troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp)); } free(objv); break; case TRIG_MSG: /* The proper way of doing things, according to #tcl on freenode (they'd know) */ command = Tcl_NewStringObj(trig->command, strlen(trig->command)); nick = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick)); uhost = Tcl_NewStringObj(data->prefix->host, strlen(data->prefix->host)); hand = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick)); /* This is stupid, I don't even remember why the hell I did this */ my_arg = ((&data->rest_str[strlen(trig->mask)] == NULL) || &data->rest_str[strlen(trig->mask)+1] == NULL) ? "" : &data->rest_str[strlen(trig->mask)+1]; text = Tcl_NewStringObj(my_arg, strlen(my_arg)); /* We need to increase the reference count, because if TCL suddenly gets some * time for GC, it will notice a zero reference count */ Tcl_IncrRefCount(command); Tcl_IncrRefCount(nick); Tcl_IncrRefCount(uhost); Tcl_IncrRefCount(hand); Tcl_IncrRefCount(text); /* I don't need a NULL last array element */ objv = tmalloc(sizeof(Tcl_Obj *) * 5); objv[0] = command; objv[1] = nick; objv[2] = uhost; objv[3] = hand; objv[4] = text; /* Call <command> <nick> <uhost> <hand> <chan> <arg> */ ret = Tcl_EvalObjv(net->tclinterp, 5, objv, TCL_EVAL_GLOBAL); /* Decrement the reference count so the GC will catch it */ Tcl_DecrRefCount(command); Tcl_DecrRefCount(nick); Tcl_DecrRefCount(uhost); Tcl_DecrRefCount(hand); Tcl_DecrRefCount(text); /* If we returned an error, send it to trollbot's warning channel */ if (ret == TCL_ERROR) { troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp)); } free(objv); break; case TRIG_MSGM: /* The proper way of doing things, according to #tcl on freenode (they'd know) */ command = Tcl_NewStringObj(trig->command, strlen(trig->command)); nick = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick)); uhost = Tcl_NewStringObj(data->prefix->host, strlen(data->prefix->host)); hand = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick)); /* This is stupid, I don't even remember why the hell I did this */ text = Tcl_NewStringObj(data->rest_str, strlen(data->rest_str)); /* We need to increase the reference count, because if TCL suddenly gets some * time for GC, it will notice a zero reference count */ Tcl_IncrRefCount(command); Tcl_IncrRefCount(nick); Tcl_IncrRefCount(uhost); Tcl_IncrRefCount(hand); Tcl_IncrRefCount(text); /* I don't need a NULL last array element */ objv = tmalloc(sizeof(Tcl_Obj *) * 5); objv[0] = command; objv[1] = nick; objv[2] = uhost; objv[3] = hand; objv[4] = text; /* Call <command> <nick> <uhost> <hand> <chan> <arg> */ ret = Tcl_EvalObjv(net->tclinterp, 5, objv, TCL_EVAL_GLOBAL); /* Decrement the reference count so the GC will catch it */ Tcl_DecrRefCount(command); Tcl_DecrRefCount(nick); Tcl_DecrRefCount(uhost); Tcl_DecrRefCount(hand); Tcl_DecrRefCount(text); /* If we returned an error, send it to trollbot's warning channel */ if (ret == TCL_ERROR) { troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp)); } free(objv); break; case TRIG_TOPC: /* The proper way of doing things, according to #tcl on freenode (they'd know) */ command = Tcl_NewStringObj(trig->command, strlen(trig->command)); nick = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick)); uhost = Tcl_NewStringObj(data->prefix->host, strlen(data->prefix->host)); hand = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick)); chan = Tcl_NewStringObj(data->c_params[0], strlen(data->c_params[0])); text = Tcl_NewStringObj(data->rest_str, strlen(data->rest_str)); /* We need to increase the reference count, because if TCL suddenly gets some * time for GC, it will notice a zero reference count */ Tcl_IncrRefCount(command); Tcl_IncrRefCount(nick); Tcl_IncrRefCount(uhost); Tcl_IncrRefCount(hand); Tcl_IncrRefCount(chan); Tcl_IncrRefCount(text); /* I don't need a NULL last array element */ objv = tmalloc(sizeof(Tcl_Obj *) * 6); objv[0] = command; objv[1] = nick; objv[2] = uhost; objv[3] = hand; objv[4] = chan; objv[5] = text; /* Call <command> <nick> <uhost> <hand> <chan> <arg> */ ret = Tcl_EvalObjv(net->tclinterp, 6, objv, TCL_EVAL_GLOBAL); /* Decrement the reference count so the GC will catch it */ Tcl_DecrRefCount(command); Tcl_DecrRefCount(nick); Tcl_DecrRefCount(uhost); Tcl_DecrRefCount(hand); Tcl_DecrRefCount(chan); Tcl_DecrRefCount(text); /* If we returned an error, send it to trollbot's warning channel */ if (ret == TCL_ERROR) { troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp)); } free(objv); break; case TRIG_RAW: /* The proper way of doing things, according to #tcl on freenode (they'd know) */ command = Tcl_NewStringObj(trig->command, strlen(trig->command)); from = Tcl_NewStringObj(data->c_params[0], strlen(data->c_params[0])); keyword = Tcl_NewStringObj(trig->command, strlen(trig->command)); text = Tcl_NewStringObj(data->rest_str, strlen(data->rest_str)); /* We need to increase the reference count, because if TCL suddenly gets some * time for GC, it will notice a zero reference count */ Tcl_IncrRefCount(command); Tcl_IncrRefCount(from); Tcl_IncrRefCount(keyword); Tcl_IncrRefCount(text); /* I don't need a NULL last array element */ objv = tmalloc(sizeof(Tcl_Obj *) * 4); objv[0] = command; objv[1] = from; objv[2] = keyword; objv[3] = text; /* Call <command> <nick> <uhost> <hand> <chan> <arg> */ ret = Tcl_EvalObjv(net->tclinterp, 4, objv, TCL_EVAL_GLOBAL); /* Decrement the reference count so the GC will catch it */ Tcl_DecrRefCount(command); Tcl_DecrRefCount(from); Tcl_DecrRefCount(keyword); Tcl_DecrRefCount(text); /* If we returned an error, send it to trollbot's warning channel */ if (ret == TCL_ERROR) { troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp)); } free(objv); break; /* :[email protected] JOIN :#test */ case TRIG_JOIN: /* The proper way of doing things, according to #tcl on freenode (they'd know) */ command = Tcl_NewStringObj(trig->command, strlen(trig->command)); nick = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick)); uhost = Tcl_NewStringObj(data->prefix->host, strlen(data->prefix->host)); hand = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick)); chan = Tcl_NewStringObj(data->rest_str, strlen(data->rest_str)); /* We need to increase the reference count, because if TCL suddenly gets some * time for GC, it will notice a zero reference count */ Tcl_IncrRefCount(command); Tcl_IncrRefCount(nick); Tcl_IncrRefCount(uhost); Tcl_IncrRefCount(hand); Tcl_IncrRefCount(chan); /* I don't need a NULL last array element */ objv = tmalloc(sizeof(Tcl_Obj *) * 5); objv[0] = command; objv[1] = nick; objv[2] = uhost; objv[3] = hand; objv[4] = chan; /* Call <command> <nick> <uhost> <hand> <chan> <arg> */ ret = Tcl_EvalObjv(net->tclinterp, 5, objv, TCL_EVAL_GLOBAL); /* Decrement the reference count so the GC will catch it */ Tcl_DecrRefCount(command); Tcl_DecrRefCount(nick); Tcl_DecrRefCount(uhost); Tcl_DecrRefCount(hand); Tcl_DecrRefCount(chan); /* If we returned an error, send it to trollbot's warning channel */ if (ret == TCL_ERROR) { troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp)); } free(objv); break; /* :[email protected] PART #boo :eat my shit */ case TRIG_PART: /* The proper way of doing things, according to #tcl on freenode (they'd know) */ command = Tcl_NewStringObj(trig->command, strlen(trig->command)); nick = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick)); uhost = Tcl_NewStringObj(data->prefix->host, strlen(data->prefix->host)); hand = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick)); chan = Tcl_NewStringObj(data->c_params[0], strlen(data->c_params[0])); msg = Tcl_NewStringObj(data->rest_str, strlen(data->rest_str)); /* We need to increase the reference count, because if TCL suddenly gets some * time for GC, it will notice a zero reference count */ Tcl_IncrRefCount(command); Tcl_IncrRefCount(nick); Tcl_IncrRefCount(uhost); Tcl_IncrRefCount(hand); Tcl_IncrRefCount(chan); Tcl_IncrRefCount(msg); /* I don't need a NULL last array element */ objv = tmalloc(sizeof(Tcl_Obj *) * 6); objv[0] = command; objv[1] = nick; objv[2] = uhost; objv[3] = hand; objv[4] = chan; objv[5] = msg; /* Call <command> <nick> <uhost> <hand> <chan> <arg> */ ret = Tcl_EvalObjv(net->tclinterp, 6, objv, TCL_EVAL_GLOBAL); /* Decrement the reference count so the GC will catch it */ Tcl_DecrRefCount(command); Tcl_DecrRefCount(nick); Tcl_DecrRefCount(uhost); Tcl_DecrRefCount(hand); Tcl_DecrRefCount(chan); Tcl_DecrRefCount(msg); /* If we returned an error, send it to trollbot's warning channel */ if (ret == TCL_ERROR) { troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp)); } free(objv); break; } }
void TkMakeBezierPostscript( Tcl_Interp *interp, /* Interpreter in whose result the Postscript * is to be stored. */ Tk_Canvas canvas, /* Canvas widget for which the Postscript is * being generated. */ double *pointPtr, /* Array of input coordinates: x0, y0, x1, y1, * etc.. */ int numPoints) /* Number of points at pointPtr. */ { int closed, i; int numCoords = numPoints*2; double control[8]; Tcl_Obj *psObj; /* * If the curve is a closed one then generate a special spline that spans * the last points and the first ones. Otherwise just put the first point * into the path. */ if ((pointPtr[0] == pointPtr[numCoords-2]) && (pointPtr[1] == pointPtr[numCoords-1])) { closed = 1; control[0] = 0.5*pointPtr[numCoords-4] + 0.5*pointPtr[0]; control[1] = 0.5*pointPtr[numCoords-3] + 0.5*pointPtr[1]; control[2] = 0.167*pointPtr[numCoords-4] + 0.833*pointPtr[0]; control[3] = 0.167*pointPtr[numCoords-3] + 0.833*pointPtr[1]; control[4] = 0.833*pointPtr[0] + 0.167*pointPtr[2]; control[5] = 0.833*pointPtr[1] + 0.167*pointPtr[3]; control[6] = 0.5*pointPtr[0] + 0.5*pointPtr[2]; control[7] = 0.5*pointPtr[1] + 0.5*pointPtr[3]; psObj = Tcl_ObjPrintf( "%.15g %.15g moveto\n" "%.15g %.15g %.15g %.15g %.15g %.15g curveto\n", control[0], Tk_CanvasPsY(canvas, control[1]), control[2], Tk_CanvasPsY(canvas, control[3]), control[4], Tk_CanvasPsY(canvas, control[5]), control[6], Tk_CanvasPsY(canvas, control[7])); } else { closed = 0; control[6] = pointPtr[0]; control[7] = pointPtr[1]; psObj = Tcl_ObjPrintf("%.15g %.15g moveto\n", control[6], Tk_CanvasPsY(canvas, control[7])); } /* * Cycle through all the remaining points in the curve, generating a curve * section for each vertex in the linear path. */ for (i = numPoints-2, pointPtr += 2; i > 0; i--, pointPtr += 2) { control[2] = 0.333*control[6] + 0.667*pointPtr[0]; control[3] = 0.333*control[7] + 0.667*pointPtr[1]; /* * Set up the last two control points. This is done differently for * the last spline of an open curve than for other cases. */ if ((i == 1) && !closed) { control[6] = pointPtr[2]; control[7] = pointPtr[3]; } else { control[6] = 0.5*pointPtr[0] + 0.5*pointPtr[2]; control[7] = 0.5*pointPtr[1] + 0.5*pointPtr[3]; } control[4] = 0.333*control[6] + 0.667*pointPtr[0]; control[5] = 0.333*control[7] + 0.667*pointPtr[1]; Tcl_AppendPrintfToObj(psObj, "%.15g %.15g %.15g %.15g %.15g %.15g curveto\n", control[2], Tk_CanvasPsY(canvas, control[3]), control[4], Tk_CanvasPsY(canvas, control[5]), control[6], Tk_CanvasPsY(canvas, control[7])); } Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj); Tcl_DecrRefCount(psObj); }
/* ARGSUSED */ int Tcl_ScanObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *format; int numVars, nconversions, totalVars = -1; int objIndex, offset, i, result, code; long value; const char *string, *end, *baseString; char op = 0; int width, underflow = 0; Tcl_WideInt wideValue; Tcl_UniChar ch, sch; Tcl_Obj **objs = NULL, *objPtr = NULL; int flags; char buf[513]; /* Temporary buffer to hold scanned number * strings before they are passed to * strtoul. */ if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "string format ?varName ...?"); return TCL_ERROR; } format = Tcl_GetStringFromObj(objv[2], NULL); numVars = objc-3; /* * Check for errors in the format string. */ if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) { return TCL_ERROR; } /* * Allocate space for the result objects. */ if (totalVars > 0) { objs = ckalloc(sizeof(Tcl_Obj *) * totalVars); for (i = 0; i < totalVars; i++) { objs[i] = NULL; } } string = Tcl_GetStringFromObj(objv[1], NULL); baseString = string; /* * Iterate over the format string filling in the result objects until we * reach the end of input, the end of the format string, or there is a * mismatch. */ objIndex = 0; nconversions = 0; while (*format != '\0') { int parseFlag = TCL_PARSE_NO_WHITESPACE; format += Tcl_UtfToUniChar(format, &ch); flags = 0; /* * If we see whitespace in the format, skip whitespace in the string. */ if (Tcl_UniCharIsSpace(ch)) { offset = Tcl_UtfToUniChar(string, &sch); while (Tcl_UniCharIsSpace(sch)) { if (*string == '\0') { goto done; } string += offset; offset = Tcl_UtfToUniChar(string, &sch); } continue; } if (ch != '%') { literal: if (*string == '\0') { underflow = 1; goto done; } string += Tcl_UtfToUniChar(string, &sch); if (ch != sch) { goto done; } continue; } format += Tcl_UtfToUniChar(format, &ch); if (ch == '%') { goto literal; } /* * Check for assignment suppression ('*') or an XPG3-style assignment * ('%n$'). */ if (ch == '*') { flags |= SCAN_SUPPRESS; format += Tcl_UtfToUniChar(format, &ch); } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ char *formatEnd; value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */ if (*formatEnd == '$') { format = formatEnd+1; format += Tcl_UtfToUniChar(format, &ch); objIndex = (int) value - 1; } } /* * Parse any width specifier. */ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ width = (int) strtoul(format-1, (char **) &format, 10);/* INTL: "C" locale. */ format += Tcl_UtfToUniChar(format, &ch); } else { width = 0; } /* * Handle any size specifier. */ switch (ch) { case 'l': if (*format == 'l') { flags |= SCAN_BIG; format += 1; format += Tcl_UtfToUniChar(format, &ch); break; } case 'L': flags |= SCAN_LONGER; /* * Fall through so we skip to the next character. */ case 'h': format += Tcl_UtfToUniChar(format, &ch); } /* * Handle the various field types. */ switch (ch) { case 'n': if (!(flags & SCAN_SUPPRESS)) { objPtr = Tcl_NewIntObj(string - baseString); Tcl_IncrRefCount(objPtr); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; } nconversions++; continue; case 'd': op = 'i'; parseFlag |= TCL_PARSE_DECIMAL_ONLY; break; case 'i': op = 'i'; parseFlag |= TCL_PARSE_SCAN_PREFIXES; break; case 'o': op = 'i'; parseFlag |= TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES; break; case 'x': op = 'i'; parseFlag |= TCL_PARSE_HEXADECIMAL_ONLY; break; case 'b': op = 'i'; parseFlag |= TCL_PARSE_BINARY_ONLY; break; case 'u': op = 'i'; parseFlag |= TCL_PARSE_DECIMAL_ONLY; flags |= SCAN_UNSIGNED; break; case 'f': case 'e': case 'g': op = 'f'; break; case 's': op = 's'; break; case 'c': op = 'c'; flags |= SCAN_NOSKIP; break; case '[': op = '['; flags |= SCAN_NOSKIP; break; } /* * At this point, we will need additional characters from the string * to proceed. */ if (*string == '\0') { underflow = 1; goto done; } /* * Skip any leading whitespace at the beginning of a field unless the * format suppresses this behavior. */ if (!(flags & SCAN_NOSKIP)) { while (*string != '\0') { offset = Tcl_UtfToUniChar(string, &sch); if (!Tcl_UniCharIsSpace(sch)) { break; } string += offset; } if (*string == '\0') { underflow = 1; goto done; } } /* * Perform the requested scanning operation. */ switch (op) { case 's': /* * Scan a string up to width characters or whitespace. */ if (width == 0) { width = ~0; } end = string; while (*end != '\0') { offset = Tcl_UtfToUniChar(end, &sch); if (Tcl_UniCharIsSpace(sch)) { break; } end += offset; if (--width == 0) { break; } } if (!(flags & SCAN_SUPPRESS)) { objPtr = Tcl_NewStringObj(string, end-string); Tcl_IncrRefCount(objPtr); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; } string = end; break; case '[': { CharSet cset; if (width == 0) { width = ~0; } end = string; format = BuildCharSet(&cset, format); while (*end != '\0') { offset = Tcl_UtfToUniChar(end, &sch); if (!CharInSet(&cset, (int)sch)) { break; } end += offset; if (--width == 0) { break; } } ReleaseCharSet(&cset); if (string == end) { /* * Nothing matched the range, stop processing. */ goto done; } if (!(flags & SCAN_SUPPRESS)) { objPtr = Tcl_NewStringObj(string, end-string); Tcl_IncrRefCount(objPtr); objs[objIndex++] = objPtr; } string = end; break; } case 'c': /* * Scan a single Unicode character. */ string += Tcl_UtfToUniChar(string, &sch); if (!(flags & SCAN_SUPPRESS)) { objPtr = Tcl_NewIntObj((int)sch); Tcl_IncrRefCount(objPtr); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; } break; case 'i': /* * Scan an unsigned or signed integer. */ objPtr = Tcl_NewLongObj(0); Tcl_IncrRefCount(objPtr); if (width == 0) { width = ~0; } if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width, &end, TCL_PARSE_INTEGER_ONLY | parseFlag)) { Tcl_DecrRefCount(objPtr); if (width < 0) { if (*end == '\0') { underflow = 1; } } else { if (end == string + width) { underflow = 1; } } goto done; } string = end; if (flags & SCAN_SUPPRESS) { Tcl_DecrRefCount(objPtr); break; } if (flags & SCAN_LONGER) { if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */ if (TclGetString(objPtr)[0] == '-') { wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */ } } if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { sprintf(buf, "%" TCL_LL_MODIFIER "u", (Tcl_WideUInt)wideValue); Tcl_SetStringObj(objPtr, buf, -1); } else { Tcl_SetWideIntObj(objPtr, wideValue); } } else if (!(flags & SCAN_BIG)) { if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) { if (TclGetString(objPtr)[0] == '-') { value = LONG_MIN; } else { value = LONG_MAX; } } if ((flags & SCAN_UNSIGNED) && (value < 0)) { sprintf(buf, "%lu", value); /* INTL: ISO digit */ Tcl_SetStringObj(objPtr, buf, -1); } else { Tcl_SetLongObj(objPtr, value); } } objs[objIndex++] = objPtr; break; case 'f': /* * Scan a floating point number */ objPtr = Tcl_NewDoubleObj(0.0); Tcl_IncrRefCount(objPtr); if (width == 0) { width = ~0; } if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width, &end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE)) { Tcl_DecrRefCount(objPtr); if (width < 0) { if (*end == '\0') { underflow = 1; } } else { if (end == string + width) { underflow = 1; } } goto done; } else if (flags & SCAN_SUPPRESS) { Tcl_DecrRefCount(objPtr); string = end; } else { double dvalue; if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) { #ifdef ACCEPT_NAN if (objPtr->typePtr == &tclDoubleType) { dvalue = objPtr->internalRep.doubleValue; } else #endif { Tcl_DecrRefCount(objPtr); goto done; } } Tcl_SetDoubleObj(objPtr, dvalue); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; string = end; } }
void * weechat_tcl_exec (struct t_plugin_script *script, int ret_type, const char *function, const char *format, void **argv) { int argc, i, llength; int *ret_i; char *ret_cv; void *ret_val; Tcl_Obj *cmdlist; Tcl_Interp *interp; struct t_plugin_script *old_tcl_script; old_tcl_script = tcl_current_script; tcl_current_script = script; interp = (Tcl_Interp*)script->interpreter; if (function && function[0]) { cmdlist = Tcl_NewListObj (0, NULL); Tcl_IncrRefCount (cmdlist); /* +1 */ Tcl_ListObjAppendElement (interp, cmdlist, Tcl_NewStringObj (function,-1)); } else { tcl_current_script = old_tcl_script; return NULL; } if (format && format[0]) { argc = strlen (format); for (i = 0; i < argc; i++) { switch (format[i]) { case 's': /* string */ Tcl_ListObjAppendElement (interp, cmdlist, Tcl_NewStringObj (argv[i], -1)); break; case 'i': /* integer */ Tcl_ListObjAppendElement (interp, cmdlist, Tcl_NewIntObj (*((int *)argv[i]))); break; case 'h': /* hash */ Tcl_ListObjAppendElement (interp, cmdlist, weechat_tcl_hashtable_to_dict (interp, argv[i])); break; } } } if (Tcl_ListObjLength (interp, cmdlist, &llength) != TCL_OK) llength = 0; if (Tcl_EvalObjEx (interp, cmdlist, TCL_EVAL_DIRECT) == TCL_OK) { Tcl_ListObjReplace (interp, cmdlist, 0, llength, 0, NULL); /* remove elements, decrement their ref count */ Tcl_DecrRefCount (cmdlist); /* -1 */ ret_val = NULL; if (ret_type == WEECHAT_SCRIPT_EXEC_STRING) { ret_cv = Tcl_GetStringFromObj (Tcl_GetObjResult (interp), &i); if (ret_cv) ret_val = (void *)strdup (ret_cv); else ret_val = NULL; } else if ( ret_type == WEECHAT_SCRIPT_EXEC_INT && Tcl_GetIntFromObj (interp, Tcl_GetObjResult (interp), &i) == TCL_OK) { ret_i = (int *)malloc (sizeof (*ret_i)); if (ret_i) *ret_i = i; ret_val = (void *)ret_i; } else if (ret_type == WEECHAT_SCRIPT_EXEC_HASHTABLE) { ret_val = weechat_tcl_dict_to_hashtable (interp, Tcl_GetObjResult (interp), WEECHAT_SCRIPT_HASHTABLE_DEFAULT_SIZE, WEECHAT_HASHTABLE_STRING, WEECHAT_HASHTABLE_STRING); } tcl_current_script = old_tcl_script; if (ret_val) return ret_val; weechat_printf (NULL, weechat_gettext ("%s%s: function \"%s\" must return a " "valid value"), weechat_prefix ("error"), TCL_PLUGIN_NAME, function); return NULL; } Tcl_ListObjReplace (interp, cmdlist, 0, llength, 0, NULL); /* remove elements, decrement their ref count */ Tcl_DecrRefCount (cmdlist); /* -1 */ weechat_printf (NULL, weechat_gettext ("%s%s: unable to run function \"%s\": %s"), weechat_prefix ("error"), TCL_PLUGIN_NAME, function, Tcl_GetStringFromObj (Tcl_GetObjResult (interp), &i)); tcl_current_script = old_tcl_script; return NULL; }
static int obj_Cgmap(ClientData /*UNUSED*/, Tcl_Interp *interp, int argc, Tcl_Obj * const objv[]) { Tcl_Obj *atomselect = NULL; Tcl_Obj *object = NULL; Tcl_Obj *bytes = NULL; Tcl_Obj *bytes_append = NULL; Tcl_Obj *sel = NULL; float *coords = NULL; float *coords_append = NULL; const char *blockid_field = "user"; const char *order_field = "user2"; const char *weight_field= "user3"; int nframes, natoms, ncoords, result, length; int first, last, stride; int molid, append_molid; natoms = ncoords = result = 0; molid = append_molid = 0; first = last = 0; stride = 1; nframes = 1; std::vector<float> weight; std::vector<int> bead; std::vector<int> index; // Parse Arguments int n = 1; while (n < argc) { const char *cmd = Tcl_GetString(objv[n]); if (!strncmp(cmd, "-molid", 7)) { if (Tcl_GetIntFromObj(interp,objv[n+1], &molid) != TCL_OK) {return TCL_ERROR;} n += 2; } else if (!strncmp(cmd, "-append", 8)) { if (Tcl_GetIntFromObj(interp,objv[n+1], &append_molid) != TCL_OK) {return TCL_ERROR;} n += 2; } else if (!strncmp(cmd, "-sel", 5)) { sel = objv[n+1]; n += 2; } else if (!strncmp(cmd, "-first", 5)) { if (Tcl_GetIntFromObj(interp,objv[n+1], &first) != TCL_OK) {return TCL_ERROR;} n += 2; } else if (!strncmp(cmd, "-last", 4)) { if (Tcl_GetIntFromObj(interp,objv[n+1], &last) != TCL_OK) {return TCL_ERROR;} n += 2; } else if (!strncmp(cmd, "-stride", 6)) { if (Tcl_GetIntFromObj(interp,objv[n+1], &stride) != TCL_OK) {return TCL_ERROR;} n += 2; } else if (!strncmp(cmd, "-weight", 7)) { weight_field = Tcl_GetString(objv[n+1]); n += 2; } else if (!strncmp(cmd, "-blockid", 7)) { blockid_field = Tcl_GetString(objv[n+1]); n += 2; } else if (!strncmp(cmd, "-order", 6)) { order_field = Tcl_GetString(objv[n+1]); n += 2; } else { Tcl_WrongNumArgs(interp,1,objv, (char *)"molid"); return TCL_ERROR; } } // Create an internal selection that we can manipulate if none was defined // Note that a passed selection overides the passed molid if (!sel) { Tcl_Obj *script = Tcl_ObjPrintf("atomselect %i all", molid); if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect", TCL_STATIC); return TCL_ERROR; } atomselect = Tcl_GetObjResult(interp); Tcl_IncrRefCount(atomselect); } else { // Create a internal selection that is a COPY of the passed selection atomselect = Tcl_DuplicateObj(sel); Tcl_IncrRefCount(atomselect); // Get the molid Tcl_Obj *script = Tcl_DuplicateObj(sel); Tcl_AppendToObj(script, " molid", -1); if(Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect", TCL_STATIC); return TCL_ERROR; } Tcl_Obj *molid_result = Tcl_GetObjResult(interp); if (Tcl_GetIntFromObj(interp, molid_result, &molid) != TCL_OK) {return TCL_ERROR;} } // Get the number of frames Tcl_Obj *script = Tcl_ObjPrintf("molinfo %i get numframes", molid); if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error calling molinfo for nframes", TCL_STATIC); return TCL_ERROR; } object = Tcl_GetObjResult(interp); if (Tcl_GetIntFromObj(interp, object, &nframes) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error parsing number of frames", TCL_STATIC); return TCL_ERROR; } if ( first < 0 || first >= nframes ) { Tcl_SetResult(interp, (char *) "Cgmap: illegal value of first_frame", TCL_STATIC); return TCL_ERROR; } if ( last == -1 || last > nframes || last < first ) last = nframes; // Get the number of atoms from selection script = Tcl_DuplicateObj(atomselect); Tcl_AppendToObj(script, " num", -1); if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect", TCL_STATIC); return TCL_ERROR; } object = Tcl_GetObjResult(interp); if (Tcl_GetIntFromObj(interp, object, &natoms) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error parsing number of atoms", TCL_STATIC); return TCL_ERROR; } // Make sure we actually have some atoms if (natoms == 0) { Tcl_SetResult(interp, (char *) "Cgmap: Selection or molecule contains no atoms", TCL_STATIC); return TCL_ERROR; } // Get the weights (mass) script = Tcl_DuplicateObj(atomselect); Tcl_AppendPrintfToObj (script, " get %s", weight_field); if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect for weights", TCL_STATIC); return TCL_ERROR; } ncoords = parse_vector(Tcl_GetObjResult(interp), weight, interp); if (ncoords == -1) { Tcl_SetResult(interp, (char *) "Cgmap: error parsing atomselect result", TCL_STATIC); return TCL_ERROR; } // Get the bead IDs script = Tcl_DuplicateObj(atomselect); Tcl_AppendPrintfToObj (script, " get %s", blockid_field); if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect for blocks", TCL_STATIC); return TCL_ERROR; } ncoords = parse_ivector(Tcl_GetObjResult(interp), bead, interp, true); if (ncoords == -1) { Tcl_SetResult(interp, (char *) "Cgmap: error parsing atomselect result", TCL_STATIC); return TCL_ERROR; } // Get the atom IDs, we use these as a map when accessing the coordinate array // user2 is set via ::CGit::setBeadID script = Tcl_DuplicateObj(atomselect); Tcl_AppendPrintfToObj (script, " get %s", order_field); if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect for order", TCL_STATIC); return TCL_ERROR; } ncoords = parse_ivector(Tcl_GetObjResult(interp), index, interp, true); if (ncoords == -1) { Tcl_SetResult(interp, (char *) "Cgmap: error parsing atomselect result", TCL_STATIC); return TCL_ERROR; } // Get current frame of the target mol script = Tcl_ObjPrintf("molinfo %d get frame", append_molid); if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error getting append mol's current frame", TCL_STATIC); return TCL_ERROR; } int append_frame = 0; object = Tcl_GetObjResult(interp); if (Tcl_GetIntFromObj(interp, object, &append_frame) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error parsing append mol's current frame", TCL_STATIC); return TCL_ERROR; } //Get number of atoms in target (append) mol script = Tcl_ObjPrintf("molinfo %i get numatoms", append_molid); if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error getting append mol's number of atoms", TCL_STATIC); return TCL_ERROR; } int append_natoms = 0; object = Tcl_GetObjResult(interp); if (Tcl_GetIntFromObj(interp, object, &append_natoms) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error parsing append mol's number of atoms", TCL_STATIC); return TCL_ERROR; } int print = ((last - first) / 10); if (print < 10) print = 10; if (print > 100) print = 100; //Loop over frames, calculate COMS, set coordinates in target mol for (int frame = first; frame <= last && frame < nframes; frame += stride) { if (frame % print == 0) { //Tcl_Obj *msg = Tcl_ObjPrintf ("puts \"Mapping frame %i\"", frame); Tcl_Obj *msg = Tcl_ObjPrintf ("vmdcon -info \"CGit> Mapping frame %i\"", frame); result = Tcl_EvalObjEx(interp, msg, TCL_EVAL_DIRECT); if (result != TCL_OK) { return TCL_ERROR; } } //Update the frames Tcl_Obj *mol_chgframe = Tcl_ObjPrintf ("molinfo top set frame %i", frame); if (Tcl_EvalObjEx(interp, mol_chgframe, TCL_EVAL_DIRECT) != TCL_OK) return TCL_ERROR; // Get the coordinates of the molecules in the reference mol Tcl_Obj *get_ts = Tcl_ObjPrintf("gettimestep %d %i", molid, frame); if (Tcl_EvalObjEx(interp, get_ts, TCL_EVAL_DIRECT) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error getting coordinates", TCL_STATIC); return TCL_ERROR; } bytes = Tcl_GetObjResult(interp); Tcl_IncrRefCount(bytes); Tcl_InvalidateStringRep (bytes); coords = reinterpret_cast<float *> (Tcl_GetByteArrayFromObj(bytes, &length)); /** Create a new frame for append_mol **/ Tcl_ObjPrintf("animate dup %i", append_molid); if (Tcl_EvalObjEx(interp, get_ts, TCL_EVAL_DIRECT) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error adding frame to append mol", TCL_STATIC); return TCL_ERROR; } append_frame++; Tcl_Obj *setframe = Tcl_ObjPrintf("molinfo %i set frame %i; display update", molid, frame); if (Tcl_EvalObjEx(interp, setframe, TCL_EVAL_DIRECT) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error updating source frame", TCL_STATIC); return TCL_ERROR; } // Copy PBC conditions Tcl_Obj *setpbc = Tcl_ObjPrintf("molinfo %i set {a b c} [molinfo %i get {a b c}]", append_molid, molid); if (Tcl_EvalObjEx(interp, setpbc, TCL_EVAL_DIRECT) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error updating PBC", TCL_STATIC); return TCL_ERROR; } // Get the coordinates of the molecules in the target (append) mol get_ts = Tcl_ObjPrintf("gettimestep %d %i", append_molid, append_frame); if (Tcl_EvalObjEx(interp, get_ts, TCL_EVAL_DIRECT) != TCL_OK) { Tcl_SetResult(interp, (char *) "Cgmap: error getting coordinates", TCL_STATIC); return TCL_ERROR; } bytes_append = Tcl_GetObjResult(interp); Tcl_IncrRefCount(bytes_append); Tcl_InvalidateStringRep(bytes_append); coords_append = reinterpret_cast<float *> (Tcl_GetByteArrayFromObj(bytes_append, &length)); //loop over coordinates and beads, calculate COMs int current_bead, current_atom; current_bead = current_atom = 0; // Nested loop to work on each bead at a time float w,x,y,z; int j = 0; for (int start_atom = 0; start_atom < natoms; ) { current_bead = bead[start_atom]; w = x = y = z = 0; // Calculate COM for each bead for ( current_atom = start_atom; current_atom < natoms && bead[current_atom] == current_bead; current_atom++) { //Lookup the atom index from the selection unsigned int idx = index[current_atom]; float tw = weight[current_atom]; w += tw; x += tw * coords[3*idx]; y += tw * coords[3*idx+1]; z += tw * coords[3*idx+2]; } if (w == 0) { Tcl_SetResult(interp, (char *) "Cgmap: Bad weight can't total zero", TCL_STATIC); return TCL_ERROR; } // Insert calculated COMS into append_mols coordinate array // Need to figure out some kind of bounds checking here... coords_append[3 * j ] = x / w; coords_append[3 * j + 1] = y / w; coords_append[3 * j + 2] = z / w; start_atom = current_atom; j++; } // bead loop // call rawtimestep to set byte array for append_mol Tcl_Obj *set_ts[5]; set_ts[0] = Tcl_NewStringObj("rawtimestep", -1); set_ts[1] = Tcl_ObjPrintf("%d",append_molid); set_ts[2] = bytes_append; set_ts[3] = Tcl_NewStringObj("-frame", -1); set_ts[4] = Tcl_NewIntObj(append_frame); if (Tcl_EvalObjv (interp, 5, set_ts, 0) != TCL_OK) return TCL_ERROR; //Cleanup Tcl_DecrRefCount(bytes); Tcl_DecrRefCount(bytes_append); } // Frame loop //Cleanup Tcl_DecrRefCount(atomselect); Tcl_SetResult(interp, (char *) "", TCL_STATIC); return TCL_OK; }
/* ARGSUSED */ int Tcl_GetsObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ int lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *linePtr, *chanObjPtr; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?"); return TCL_ERROR; } chanObjPtr = objv[1]; if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), "\" wasn't opened for reading", NULL); return TCL_ERROR; } linePtr = Tcl_NewObj(); lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { Tcl_DecrRefCount(linePtr); /* * TIP #219. Capture error messages put by the driver into the * bypass area and put them into the regular interpreter result. * Fall back to the regular message if nothing was found in the * bypass. */ if (!TclChanCaughtErrorBypass(interp, chan)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading \"", TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), NULL); } return TCL_ERROR; } lineLen = -1; } if (objc == 3) { if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); return TCL_OK; } else { Tcl_SetObjResult(interp, linePtr); } return TCL_OK; }
void Tcl_Main( int argc, /* Number of arguments. */ char **argv, /* Array of argument strings. */ Tcl_AppInitProc *appInitProc) /* Application-specific initialization * function to call after most initialization * but before starting to execute commands. */ { Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL; CONST char *encodingName = NULL; PromptType prompt = PROMPT_START; int code, length, tty, exitCode = 0; Tcl_Channel inChannel, outChannel, errChannel; Tcl_Interp *interp; Tcl_DString appName; Tcl_FindExecutable(argv[0]); interp = Tcl_CreateInterp(); Tcl_InitMemory(interp); /* * If the application has not already set a startup script, parse the * first few command line arguments to determine the script path and * encoding. */ if (NULL == Tcl_GetStartupScript(NULL)) { /* * Check whether first 3 args (argv[1] - argv[3]) look like * -encoding ENCODING FILENAME * or like * FILENAME */ if ((argc > 3) && (0 == strcmp("-encoding", argv[1])) && ('-' != argv[3][0])) { Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]); argc -= 3; argv += 3; } else if ((argc > 1) && ('-' != argv[1][0])) { Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL); argc--; argv++; } } path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName); } else { CONST char *pathName = Tcl_GetStringFromObj(path, &length); Tcl_ExternalToUtfDString(NULL, pathName, length, &appName); path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1); Tcl_SetStartupScript(path, encodingName); } Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY); Tcl_DStringFree(&appName); argc--; argv++; Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { Tcl_DString ds; Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds); Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj( Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); Tcl_DStringFree(&ds); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. */ tty = isatty(0); Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. */ Tcl_Preserve((ClientData) interp); if ((*appInitProc)(interp) != TCL_OK) { errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel) { Tcl_WriteChars(errChannel, "application-specific initialization failed: ", -1); Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); Tcl_WriteChars(errChannel, "\n", 1); } } if (Tcl_InterpDeleted(interp)) { goto done; } if (Tcl_LimitExceeded(interp)) { goto done; } /* * If a script file was specified then just source that file and quit. * Must fetch it again, as the appInitProc might have reset it. */ path = Tcl_GetStartupScript(&encodingName); if (path != NULL) { code = Tcl_FSEvalFileEx(interp, path, encodingName); if (code != TCL_OK) { errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); Tcl_Obj *keyPtr, *valuePtr; TclNewLiteralStringObj(keyPtr, "-errorinfo"); Tcl_IncrRefCount(keyPtr); Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); if (valuePtr) { Tcl_WriteObj(errChannel, valuePtr); } Tcl_WriteChars(errChannel, "\n", 1); } exitCode = 1; } goto done; } /* * We're running interactively. Source a user-specific startup file if the * application specified one and if the file exists. */ Tcl_SourceRCFile(interp); if (Tcl_LimitExceeded(interp)) { goto done; } /* * Process commands from stdin until there's an end-of-file. Note that we * need to fetch the standard channels again after every eval, since they * may have been changed. */ commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(commandPtr); /* * Get a new value for tty if anyone writes to ::tcl_interactive */ Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) { if (mainLoopProc == NULL) { if (tty) { Prompt(interp, &prompt); if (Tcl_InterpDeleted(interp)) { break; } if (Tcl_LimitExceeded(interp)) { break; } inChannel = Tcl_GetStdChannel(TCL_STDIN); if (inChannel == (Tcl_Channel) NULL) { break; } } if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_DuplicateObj(commandPtr); Tcl_IncrRefCount(commandPtr); } length = Tcl_GetsObj(inChannel, commandPtr); if (length < 0) { if (Tcl_InputBlocked(inChannel)) { /* * This can only happen if stdin has been set to * non-blocking. In that case cycle back and try again. * This sets up a tight polling loop (since we have no * event loop running). If this causes bad CPU hogging, * we might try toggling the blocking on stdin instead. */ continue; } /* * Either EOF, or an error on stdin; we're done */ break; } /* * Add the newline removed by Tcl_GetsObj back to the string. * Have to add it back before testing completeness, because * it can make a difference. [Bug 1775878]. */ if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_DuplicateObj(commandPtr); Tcl_IncrRefCount(commandPtr); } Tcl_AppendToObj(commandPtr, "\n", 1); if (!TclObjCommandComplete(commandPtr)) { prompt = PROMPT_CONTINUE; continue; } prompt = PROMPT_START; /* * The final newline is syntactically redundant, and causes * some error messages troubles deeper in, so lop it back off. */ Tcl_GetStringFromObj(commandPtr, &length); Tcl_SetObjLength(commandPtr, --length); code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); errChannel = Tcl_GetStdChannel(TCL_STDERR); Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(commandPtr); if (code != TCL_OK) { if (errChannel) { Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); Tcl_WriteChars(errChannel, "\n", 1); } } else if (tty) { resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && outChannel) { Tcl_WriteObj(outChannel, resultPtr); Tcl_WriteChars(outChannel, "\n", 1); } Tcl_DecrRefCount(resultPtr); } } else { /* (mainLoopProc != NULL) */ /* * If a main loop has been defined while running interactively, we * want to start a fileevent based prompt by establishing a * channel handler for stdin. */ InteractiveState *isPtr = NULL; if (inChannel) { if (tty) { Prompt(interp, &prompt); } isPtr = (InteractiveState *) ckalloc((int) sizeof(InteractiveState)); isPtr->input = inChannel; isPtr->tty = tty; isPtr->commandPtr = commandPtr; isPtr->prompt = prompt; isPtr->interp = interp; Tcl_UnlinkVar(interp, "tcl_interactive"); Tcl_LinkVar(interp, "tcl_interactive", (char *) &(isPtr->tty), TCL_LINK_BOOLEAN); Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc, (ClientData) isPtr); } (*mainLoopProc)(); mainLoopProc = NULL; if (inChannel) { tty = isPtr->tty; Tcl_UnlinkVar(interp, "tcl_interactive"); Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN); prompt = isPtr->prompt; commandPtr = isPtr->commandPtr; if (isPtr->input != (Tcl_Channel) NULL) { Tcl_DeleteChannelHandler(isPtr->input, StdinProc, (ClientData) isPtr); } ckfree((char *)isPtr); } inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); errChannel = Tcl_GetStdChannel(TCL_STDERR); } #ifdef TCL_MEM_DEBUG /* * This code here only for the (unsupported and deprecated) [checkmem] * command. */ if (tclMemDumpFileName != NULL) { mainLoopProc = NULL; Tcl_DeleteInterp(interp); } #endif } done: if ((exitCode == 0) && (mainLoopProc != NULL) && !Tcl_LimitExceeded(interp)) { /* * If everything has gone OK so far, call the main loop proc, if it * exists. Packages (like Tk) can set it to start processing events at * this point. */ (*mainLoopProc)(); mainLoopProc = NULL; } if (commandPtr != NULL) { Tcl_DecrRefCount(commandPtr); } /* * Rather than calling exit, invoke the "exit" command so that users can * replace "exit" with some other command to do additional cleanup on * exit. The Tcl_EvalObjEx call should never return. */ if (!Tcl_InterpDeleted(interp)) { if (!Tcl_LimitExceeded(interp)) { Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); Tcl_IncrRefCount(cmd); Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(cmd); } /* * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual * is happening. Maybe interp has been deleted; maybe [exit] was * redefined, maybe we've blown up because of an exceeded limit. We * still want to cleanup and exit. */ if (!Tcl_InterpDeleted(interp)) { Tcl_DeleteInterp(interp); } } Tcl_SetStartupScript(NULL, NULL); /* * If we get here, the master interp has been deleted. Allow its * destruction with the last matching Tcl_Release. */ Tcl_Release((ClientData) interp); Tcl_Exit(exitCode); }
/* ARGSUSED */ int Tcl_ReadObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ int newline, i; /* Discard newline at end? */ int toRead; /* How many bytes to read? */ int charactersRead; /* How many characters were read? */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *resultPtr, *chanObjPtr; if ((objc != 2) && (objc != 3)) { Interp *iPtr; argerror: iPtr = (Interp *) interp; Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?"); /* * Do not append directly; that makes ensembles using this command as * a subcommand produce the wrong message. */ iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId"); iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; return TCL_ERROR; } i = 1; newline = 0; if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { newline = 1; i++; } if (i == objc) { goto argerror; } chanObjPtr = objv[i]; if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), "\" wasn't opened for reading", NULL); return TCL_ERROR; } i++; /* Consumed channel name. */ /* * Compute how many bytes to read, and see whether the final newline * should be dropped. */ toRead = -1; if (i < objc) { char *arg; arg = TclGetString(objv[i]); if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */ if (TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { return TCL_ERROR; } } else if (strcmp(arg, "nonewline") == 0) { newline = 1; } else { Tcl_AppendResult(interp, "bad argument \"", arg, "\": should be \"nonewline\"", NULL); return TCL_ERROR; } } resultPtr = Tcl_NewObj(); Tcl_IncrRefCount(resultPtr); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead < 0) { /* * TIP #219. * Capture error messages put by the driver into the bypass area and * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. */ if (!TclChanCaughtErrorBypass(interp, chan)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading \"", TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), NULL); } Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } /* * If requested, remove the last newline in the channel if at EOF. */ if ((charactersRead > 0) && (newline != 0)) { char *result; int length; result = TclGetStringFromObj(resultPtr, &length); if (result[length - 1] == '\n') { Tcl_SetObjLength(resultPtr, length - 1); } } Tcl_SetObjResult(interp, resultPtr); Tcl_DecrRefCount(resultPtr); return TCL_OK; }
/* *--------------------------------------------------------------------------- * * HtmlImageServerGet -- * * Retrieve an HtmlImage2 object for the image at URL zUrl from * an image-server. The caller should match this call with a single * HtmlImageFree() when the image object is no longer required. * * If the image is not already in the cache, the Tcl script * configured as the widget -imagecmd is invoked. If this command * raises an error or returns an invalid result, then this function * returns NULL. A Tcl back-ground error is propagated in this case * also. * * Results: * Pointer to HtmlImage2 object containing the image from zUrl, or * NULL, if zUrl was invalid for some reason. * * Side effects: * May invoke -imagecmd script. * *--------------------------------------------------------------------------- */ HtmlImage2 * HtmlImageServerGet (HtmlImageServer *p, const char *zUrl) { Tcl_Obj *pImageCmd = p->pTree->options.imagecmd; Tcl_Interp *interp = p->pTree->interp; Tcl_HashEntry *pEntry = 0; HtmlImage2 *pImage = 0; /* Try to find the requested image in the hash table. */ if (pImageCmd) { int new_entry; pEntry = Tcl_CreateHashEntry(&p->aImage, zUrl, &new_entry); if (new_entry) { Tcl_Obj *pEval; Tcl_Obj *pResult; int rc; int nObj; Tcl_Obj **apObj = 0; Tk_Image img; /* The image could not be found in the hash table and an * -imagecmd callback is configured. The callback script * must be executed to obtain an image. Build up a script * in pEval and execute it. Put the result in variable pResult. */ pEval = Tcl_DuplicateObj(pImageCmd); Tcl_IncrRefCount(pEval); Tcl_ListObjAppendElement(interp, pEval, Tcl_NewStringObj(zUrl, -1)); rc = Tcl_EvalObjEx(interp, pEval, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL); Tcl_DecrRefCount(pEval); if (rc != TCL_OK) { goto image_get_out; } pResult = Tcl_GetObjResult(interp); /* Read the result into array apObj. If the result was * not a valid Tcl list, return NULL and raise a background * error about the badly formed list. */ rc = Tcl_ListObjGetElements(interp, pResult, &nObj, &apObj); if (rc != TCL_OK) { goto image_get_out; } if (nObj==0) { Tcl_DeleteHashEntry(pEntry); goto image_unavailable; } pImage = HtmlNew(HtmlImage2); if (nObj == 1 || nObj == 2) { img = Tk_GetImage( interp, p->pTree->tkwin, Tcl_GetString(apObj[0]), imageChanged, pImage ); } if ((nObj != 1 && nObj != 2) || !img) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "-imagecmd returned bad value", 0); HtmlFree(pImage); pImage = 0; goto image_get_out; } Tcl_SetHashValue(pEntry, (ClientData)pImage); Tcl_IncrRefCount(apObj[0]); pImage->pImageName = apObj[0]; if (nObj == 2) { Tcl_IncrRefCount(apObj[1]); pImage->pDelete = apObj[1]; } pImage->pImageServer = p; pImage->zUrl = Tcl_GetHashKey(&p->aImage, pEntry); pImage->image = img; Tk_SizeOfImage(pImage->image, &pImage->width, &pImage->height); pImage->isValid = 1; HtmlImagePixmap(pImage); } } image_get_out: pImage = (HtmlImage2 *)(pEntry ? Tcl_GetHashValue(pEntry) : 0); HtmlImageRef(pImage); if (!pImage && pImageCmd) { Tcl_BackgroundError(interp); Tcl_ResetResult(interp); assert(pEntry); Tcl_DeleteHashEntry(pEntry); } image_unavailable: return pImage; }
/* ARGSUSED */ int Tcl_ExecObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { /* * This function generates an argv array for the string arguments. It * starts out with stack-allocated space but uses dynamically-allocated * storage if needed. */ Tcl_Obj *resultPtr; const char **argv; char *string; Tcl_Channel chan; int argc, background, i, index, keepNewline, result, skip, length; int ignoreStderr; static const char *options[] = { "-ignorestderr", "-keepnewline", "--", NULL }; enum options { EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST }; /* * Check for any leading option arguments. */ keepNewline = 0; ignoreStderr = 0; for (skip = 1; skip < objc; skip++) { string = TclGetString(objv[skip]); if (string[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } if (index == EXEC_KEEPNEWLINE) { keepNewline = 1; } else if (index == EXEC_IGNORESTDERR) { ignoreStderr = 1; } else { skip++; break; } } if (objc <= skip) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?"); return TCL_ERROR; } /* * See if the command is to be run in background. */ background = 0; string = TclGetString(objv[objc - 1]); if ((string[0] == '&') && (string[1] == '\0')) { objc--; background = 1; } /* * Create the string argument array "argv". Make sure argv is large enough * to hold the argc arguments plus 1 extra for the zero end-of-argv word. */ argc = objc - skip; argv = (const char **) TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *)); /* * Copy the string conversions of each (post option) object into the * argument vector. */ for (i = 0; i < argc; i++) { argv[i] = TclGetString(objv[i + skip]); } argv[argc] = NULL; chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 : (ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR))); /* * Free the argv array. */ TclStackFree(interp, (void *)argv); if (chan == NULL) { return TCL_ERROR; } if (background) { /* * Store the list of PIDs from the pipeline in interp's result and * detach the PIDs (instead of waiting for them). */ TclGetAndDetachPids(interp, chan); if (Tcl_Close(interp, chan) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } resultPtr = Tcl_NewObj(); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { /* * TIP #219. * Capture error messages put by the driver into the bypass area * and put them into the regular interpreter result. Fall back to * the regular message if nothing was found in the bypass. */ if (!TclChanCaughtErrorBypass(interp, chan)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading output from command: ", Tcl_PosixError(interp), NULL); Tcl_DecrRefCount(resultPtr); } return TCL_ERROR; } } /* * If the process produced anything on stderr, it will have been returned * in the interpreter result. It needs to be appended to the result * string. */ result = Tcl_Close(interp, chan); Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp)); /* * If the last character of the result is a newline, then remove the * newline character. */ if (keepNewline == 0) { string = TclGetStringFromObj(resultPtr, &length); if ((length > 0) && (string[length - 1] == '\n')) { Tcl_SetObjLength(resultPtr, length - 1); } } Tcl_SetObjResult(interp, resultPtr); return result; }
void HtmlImageFree (HtmlImage2 *pImage) { if (!pImage) { return; } assert(pImage->nRef > 0); pImage->nRef--; if ( pImage->nRef == 0 && (pImage->pUnscaled || !pImage->pImageServer->isSuspendGC) ) { /* The reference count for this structure has reached zero. * Really delete it. The assert() says that an original image * cannot be deleted before all of it's scaled copies. */ assert(pImage->pUnscaled || 0 == pImage->pNext); freeImageCompressed(pImage); freeTile(pImage); if (pImage->pixmap) { HtmlTree *pTree = pImage->pImageServer->pTree; Tk_FreePixmap(Tk_Display(pTree->tkwin), pImage->pixmap); pImage->pixmap = 0; } if (pImage->image) { Tk_FreeImage(pImage->image); } if (pImage->pImageName) { Tcl_Interp *interp = pImage->pImageServer->pTree->interp; Tcl_Obj *pEval; if (!pImage->pDelete) { pEval = Tcl_NewStringObj("image delete", -1); Tcl_IncrRefCount(pEval); } else { pEval = pImage->pDelete; } Tcl_ListObjAppendElement(interp, pEval, pImage->pImageName); Tcl_EvalObjEx(interp, pEval, TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT); Tcl_DecrRefCount(pEval); Tcl_DecrRefCount(pImage->pImageName); } if (pImage->pUnscaled) { HtmlImage2 *pIter; for ( pIter = pImage->pUnscaled; pIter->pNext != pImage; pIter = pIter->pNext ) { assert(pIter->pNext); } pIter->pNext = pIter->pNext->pNext; HtmlImageFree(pImage->pUnscaled); } else { const char *zKey = pImage->zUrl; Tcl_HashTable *paImage = &pImage->pImageServer->aImage; Tcl_HashEntry *pEntry = Tcl_FindHashEntry(paImage, zKey); assert(pEntry); Tcl_DeleteHashEntry(pEntry); } HtmlFree(pImage); Tcl_CancelIdleCall(asyncPixmapify, (ClientData)pImage); } }
/* ARGSUSED */ int Tcl_AfterObjCmd( ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_WideInt ms = 0; /* Number of milliseconds to wait */ Tcl_Time wakeup; AfterInfo *afterPtr; AfterAssocData *assocPtr; int length; int index; static const char *const afterSubCmds[] = { "cancel", "idle", "info", NULL }; enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; ThreadSpecificData *tsdPtr = InitTimer(); if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } /* * Create the "after" information associated for this interpreter, if it * doesn't already exist. */ assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL); if (assocPtr == NULL) { assocPtr = ckalloc(sizeof(AfterAssocData)); assocPtr->interp = interp; assocPtr->firstAfterPtr = NULL; Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr); } /* * First lets see if the command was passed a number as the first argument. */ if (objv[1]->typePtr == &tclIntType #ifndef TCL_WIDE_INT_IS_LONG || objv[1]->typePtr == &tclWideIntType #endif || objv[1]->typePtr == &tclBignumType || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) != TCL_OK)) { index = -1; if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { const char *arg = Tcl_GetString(objv[1]); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument \"%s\": must be" " cancel, idle, info, or an integer", arg)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument", arg, NULL); return TCL_ERROR; } } /* * At this point, either index = -1 and ms contains the number of ms * to wait, or else index is the index of a subcommand. */ switch (index) { case -1: { if (ms < 0) { ms = 0; } if (objc == 2) { return AfterDelay(interp, ms); } afterPtr = ckalloc(sizeof(AfterInfo)); afterPtr->assocPtr = assocPtr; if (objc == 3) { afterPtr->commandPtr = objv[2]; } else { afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); } Tcl_IncrRefCount(afterPtr->commandPtr); /* * The variable below is used to generate unique identifiers for after * commands. This id can wrap around, which can potentially cause * problems. However, there are not likely to be problems in practice, * because after commands can only be requested to about a month in * the future, and wrap-around is unlikely to occur in less than about * 1-10 years. Thus it's unlikely that any old ids will still be * around when wrap-around occurs. */ afterPtr->id = tsdPtr->afterId; tsdPtr->afterId += 1; Tcl_GetTime(&wakeup); wakeup.sec += (long)(ms / 1000); wakeup.usec += ((long)(ms % 1000)) * 1000; if (wakeup.usec > 1000000) { wakeup.sec++; wakeup.usec -= 1000000; } afterPtr->token = TclCreateAbsoluteTimerHandler(&wakeup, AfterProc, afterPtr); afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id)); return TCL_OK; } case AFTER_CANCEL: { Tcl_Obj *commandPtr; const char *command, *tempCommand; int tempLength; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "id|command"); return TCL_ERROR; } if (objc == 3) { commandPtr = objv[2]; } else { commandPtr = Tcl_ConcatObj(objc-2, objv+2);; } command = Tcl_GetStringFromObj(commandPtr, &length); for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, &tempLength); if ((length == tempLength) && !memcmp(command, tempCommand, (unsigned) length)) { break; } } if (afterPtr == NULL) { afterPtr = GetAfterEvent(assocPtr, commandPtr); } if (objc != 3) { Tcl_DecrRefCount(commandPtr); } if (afterPtr != NULL) { if (afterPtr->token != NULL) { Tcl_DeleteTimerHandler(afterPtr->token); } else { Tcl_CancelIdleCall(AfterProc, afterPtr); } FreeAfterPtr(afterPtr); } break; } case AFTER_IDLE: if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?"); return TCL_ERROR; } afterPtr = ckalloc(sizeof(AfterInfo)); afterPtr->assocPtr = assocPtr; if (objc == 3) { afterPtr->commandPtr = objv[2]; } else { afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); } Tcl_IncrRefCount(afterPtr->commandPtr); afterPtr->id = tsdPtr->afterId; tsdPtr->afterId += 1; afterPtr->token = NULL; afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; Tcl_DoWhenIdle(AfterProc, afterPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id)); break; case AFTER_INFO: if (objc == 2) { Tcl_Obj *resultObj = Tcl_NewObj(); for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { if (assocPtr->interp == interp) { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf( "after#%d", afterPtr->id)); } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; } if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?id?"); return TCL_ERROR; } afterPtr = GetAfterEvent(assocPtr, objv[2]); if (afterPtr == NULL) { const char *eventStr = TclGetString(objv[2]); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "event \"%s\" doesn't exist", eventStr)); Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL); return TCL_ERROR; } else { Tcl_Obj *resultListPtr = Tcl_NewObj(); Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr); Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( (afterPtr->token == NULL) ? "idle" : "timer", -1)); Tcl_SetObjResult(interp, resultListPtr); } break; default: Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); } return TCL_OK; }
void TkMacOSXHandleMenuSelect( MenuID theMenu, MenuItemIndex theItem, int optionKeyPressed) { Tk_Window tkwin; Window window; TkDisplay *dispPtr; Tcl_CmdInfo dummy; int code; if (theItem == 0) { TkMacOSXClearMenubarActive(); return; } switch (theMenu) { case kAppleMenu: switch (theItem) { case kAppleAboutItem: if (optionKeyPressed || gInterp == NULL || Tcl_GetCommandInfo(gInterp, "tkAboutDialog", &dummy) == 0) { TkAboutDlg(); } else { code = Tcl_EvalEx(gInterp, "tkAboutDialog", -1, TCL_EVAL_GLOBAL); if (code != TCL_OK) { Tcl_BackgroundException(gInterp, code); } Tcl_ResetResult(gInterp); } break; } break; case kFileMenu: switch (theItem) { case kSourceItem: if (gInterp) { if (Tcl_EvalEx(gInterp, "tk_getOpenFile -filetypes {" "{{TCL Scripts} {.tcl} TEXT} {{Text Files} {} TEXT}}", -1, TCL_EVAL_GLOBAL) == TCL_OK) { Tcl_Obj *path = Tcl_GetObjResult(gInterp); int len; Tcl_GetStringFromObj(path, &len); if (len) { Tcl_IncrRefCount(path); code = Tcl_FSEvalFile(gInterp, path); if (code != TCL_OK) { Tcl_BackgroundException(gInterp, code); } Tcl_DecrRefCount(path); } } Tcl_ResetResult(gInterp); } break; case kDemoItem: if (gInterp) { Tcl_Obj *path = GetWidgetDemoPath(gInterp); if (path) { Tcl_IncrRefCount(path); code = Tcl_FSEvalFile(gInterp, path); if (code != TCL_OK) { Tcl_BackgroundException(gInterp, code); } Tcl_DecrRefCount(path); Tcl_ResetResult(gInterp); } } break; case kCloseItem: /* Send close event */ window = TkMacOSXGetXWindow(ActiveNonFloatingWindow()); dispPtr = TkGetDisplayList(); tkwin = Tk_IdToWindow(dispPtr->display, window); TkGenWMDestroyEvent(tkwin); break; } break; case kEditMenu: /* * This implementation just send the keysyms Tk thinks are associated * with function keys that do Cut, Copy & Paste on a Sun keyboard. */ GenerateEditEvent(theItem); break; default: TkMacOSXDispatchMenuEvent(theMenu, theItem); break; } /* * Finally we unhighlight the menu. */ HiliteMenu(0); }
Tcl_Obj* TnmSnmpNorm(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) { int i, code, objc; Tcl_Obj **objv; Tcl_Obj *vbListPtr = NULL; /* * The following Tcl_Objs are allocated once and reused whenever * we need to expand a varbind list containing object identifiers * without any value or type elements. */ static Tcl_Obj *nullType = NULL; static Tcl_Obj *zeroValue = NULL; static Tcl_Obj *nullValue = NULL; if (! nullType) { nullType = Tcl_NewStringObj("NULL", 4); Tcl_IncrRefCount(nullType); } if (! zeroValue) { zeroValue = Tcl_NewIntObj(0); Tcl_IncrRefCount(zeroValue); } if (! nullValue) { nullValue = Tcl_NewStringObj(NULL, 0); Tcl_IncrRefCount(nullValue); } /* * Split the varbind list into a list of varbinds. Create a * new Tcl list to hold the expanded varbind list. */ code = Tcl_ListObjGetElements(interp, objPtr, &objc, &objv); if (code != TCL_OK) { goto errorExit; } vbListPtr = Tcl_NewListObj(0, NULL); for (i = 0; i < objc; i++) { int vbc, type; Tcl_Obj **vbv, *vbPtr; TnmOid* oidPtr; Tcl_Obj *oidObjPtr, *typeObjPtr, *valueObjPtr; TnmMibNode *nodePtr = NULL; /* * Create a new varbind element in the expanded result list * for each varbind. */ vbPtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, vbListPtr, vbPtr); code = Tcl_ListObjGetElements(interp, objv[i], &vbc, &vbv); if (code != TCL_OK) { goto errorExit; } /* * Get the object identifier value from the first list * element. Check the number of list elements and assign * them to the oid, type and value variables. */ switch (vbc) { case 1: oidObjPtr = vbv[0]; typeObjPtr = nullType; valueObjPtr = nullValue; break; case 2: oidObjPtr = vbv[0]; typeObjPtr = NULL; valueObjPtr = vbv[1]; break; case 3: oidObjPtr = vbv[0]; typeObjPtr = vbv[1]; valueObjPtr = vbv[2]; break; default: { char msg[80]; sprintf(msg, "illegal number of elements in varbind %d", i); Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), msg, (char *) NULL); goto errorExit; } } /* * Check/resolve the object identifier and assign it to the * result list. Make sure to make a deep copy if the object * identifier value is shared since the string representation * must be invalidated to ensure that hexadecimal * sub-identifier are converted into decimal sub-identifier. */ oidPtr = TnmGetOidFromObj(interp, oidObjPtr); if (! oidPtr) { goto errorExit; } if (Tcl_IsShared(oidObjPtr)) { oidObjPtr = Tcl_DuplicateObj(oidObjPtr); } TnmOidObjSetRep(oidObjPtr, TNM_OID_AS_OID); Tcl_InvalidateStringRep(oidObjPtr); Tcl_ListObjAppendElement(interp, vbPtr, oidObjPtr); /* * Lookup the type in the MIB if there is no type given in the * varbind element. */ if (! typeObjPtr) { int syntax; nodePtr = TnmMibNodeFromOid(oidPtr, NULL); if (! nodePtr) { char msg[80]; sprintf(msg, "failed to lookup the type for varbind %d", i); Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), msg, (char *) NULL); goto errorExit; } syntax = (nodePtr->typePtr && nodePtr->typePtr->name) ? nodePtr->typePtr->syntax : nodePtr->syntax; typeObjPtr = Tcl_NewStringObj( TnmGetTableValue(tnmSnmpTypeTable, (unsigned) syntax), -1); } type = TnmGetTableKeyFromObj(NULL, tnmSnmpTypeTable, typeObjPtr, NULL); if (type == -1) { type = TnmGetTableKeyFromObj(NULL, tnmSnmpExceptionTable, typeObjPtr, NULL); if (type == -1) { char msg[80]; invalidType: sprintf(msg, "illegal type in varbind %d", i); Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), msg, (char *) NULL); goto errorExit; } } Tcl_ListObjAppendElement(interp, vbPtr, typeObjPtr); /* * Check the value and perform any conversions needed to * convert the value into the base type representation. */ switch (type) { case ASN1_INTEGER: { long longValue; code = Tcl_GetLongFromObj(interp, valueObjPtr, &longValue); if (code != TCL_OK) { if (! nodePtr) { nodePtr = TnmMibNodeFromOid(oidPtr, NULL); } if (nodePtr) { Tcl_Obj *value; value = TnmMibScanValue(nodePtr->typePtr, nodePtr->syntax, valueObjPtr); if (! value) { goto errorExit; } Tcl_ResetResult(interp); code = Tcl_GetLongFromObj(interp, value, &longValue); } if (code != TCL_OK) { goto errorExit; } valueObjPtr = Tcl_NewLongObj(longValue); } if (flags & TNM_SNMP_NORM_INT) { if (! nodePtr) { nodePtr = TnmMibNodeFromOid(oidPtr, NULL); } if (nodePtr && nodePtr->typePtr) { Tcl_Obj *newPtr; newPtr = TnmMibFormatValue(nodePtr->typePtr, nodePtr->syntax, valueObjPtr); if (newPtr) { valueObjPtr = newPtr; } } } break; } case ASN1_COUNTER32: case ASN1_GAUGE32: case ASN1_TIMETICKS: { TnmUnsigned32 u; code = TnmGetUnsigned32FromObj(interp, valueObjPtr, &u); if (code != TCL_OK) { goto errorExit; } break; } case ASN1_COUNTER64: { TnmUnsigned64 u; code = TnmGetUnsigned64FromObj(interp, valueObjPtr, &u); if (code != TCL_OK) { goto errorExit; } break; } case ASN1_IPADDRESS: { if (TnmGetIpAddressFromObj(interp, valueObjPtr) == NULL) { goto errorExit; } Tcl_InvalidateStringRep(valueObjPtr); break; } case ASN1_OBJECT_IDENTIFIER: if (! TnmGetOidFromObj(interp, valueObjPtr)) { goto errorExit; } if (Tcl_IsShared(valueObjPtr)) { valueObjPtr = Tcl_DuplicateObj(valueObjPtr); } if (flags & TNM_SNMP_NORM_OID) { TnmOidObjSetRep(valueObjPtr, TNM_OID_AS_NAME); } else { TnmOidObjSetRep(valueObjPtr, TNM_OID_AS_OID); } Tcl_InvalidateStringRep(valueObjPtr); break; case ASN1_OCTET_STRING: { int len; if (! nodePtr) { nodePtr = TnmMibNodeFromOid(oidPtr, NULL); } if (nodePtr) { Tcl_Obj *scan; scan = TnmMibScanValue(nodePtr->typePtr, nodePtr->syntax, valueObjPtr); if (scan) { valueObjPtr = scan; } } if (TnmGetOctetStringFromObj(interp, valueObjPtr, &len) == NULL) { goto errorExit; } Tcl_InvalidateStringRep(valueObjPtr); break; } case ASN1_NULL: valueObjPtr = nullValue; break; default: goto invalidType; } Tcl_ListObjAppendElement(interp, vbPtr, valueObjPtr); } return vbListPtr; errorExit: if (vbListPtr) { Tcl_DecrRefCount(vbListPtr); } return NULL; }
int TclpMatchInDirectory( Tcl_Interp *interp, /* Interpreter to receive errors. */ Tcl_Obj *resultPtr, /* List object to lappend results. */ Tcl_Obj *pathPtr, /* Contains path to directory to search. */ CONST char *pattern, /* Pattern to match against. */ Tcl_GlobTypeData *types) /* Object containing list of acceptable types. * May be NULL. In particular the directory * flag is very important. */ { CONST char *native; Tcl_Obj *fileNamePtr; int matchResult = 0; if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) { /* * The native filesystem never adds mounts. */ return TCL_OK; } fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr); if (fileNamePtr == NULL) { return TCL_ERROR; } if (pattern == NULL || (*pattern == '\0')) { /* * Match a file directly. */ Tcl_Obj *tailPtr; CONST char *nativeTail; native = (CONST char*) Tcl_FSGetNativePath(pathPtr); tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL); nativeTail = (CONST char*) Tcl_FSGetNativePath(tailPtr); matchResult = NativeMatchType(interp, native, nativeTail, types); if (matchResult == 1) { Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); } Tcl_DecrRefCount(tailPtr); Tcl_DecrRefCount(fileNamePtr); } else { DIR *d; Tcl_DirEntry *entryPtr; CONST char *dirName; int dirLength; int matchHidden, matchHiddenPat; int nativeDirLen; Tcl_StatBuf statBuf; Tcl_DString ds; /* native encoding of dir */ Tcl_DString dsOrig; /* utf-8 encoding of dir */ Tcl_DStringInit(&dsOrig); dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); /* * Make sure that the directory part of the name really is a * directory. If the directory name is "", use the name "." instead, * because some UNIX systems don't treat "" like "." automatically. * Keep the "" for use in generating file names, otherwise "glob * foo.c" would return "./foo.c". */ if (dirLength == 0) { dirName = "."; } else { dirName = Tcl_DStringValue(&dsOrig); /* * Make sure we have a trailing directory delimiter. */ if (dirName[dirLength-1] != '/') { dirName = Tcl_DStringAppend(&dsOrig, "/", 1); dirLength++; } } /* * Now open the directory for reading and iterate over the contents. */ native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds); if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */ || !S_ISDIR(statBuf.st_mode)) { Tcl_DStringFree(&dsOrig); Tcl_DStringFree(&ds); Tcl_DecrRefCount(fileNamePtr); return TCL_OK; } d = opendir(native); /* INTL: Native. */ if (d == NULL) { Tcl_DStringFree(&ds); if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't read directory \"", Tcl_DStringValue(&dsOrig), "\": ", Tcl_PosixError(interp), (char *) NULL); } Tcl_DStringFree(&dsOrig); Tcl_DecrRefCount(fileNamePtr); return TCL_ERROR; } nativeDirLen = Tcl_DStringLength(&ds); /* * Check to see if -type or the pattern requests hidden files. */ matchHiddenPat = (pattern[0] == '.') || ((pattern[0] == '\\') && (pattern[1] == '.')); matchHidden = matchHiddenPat || (types && (types->perm & TCL_GLOB_PERM_HIDDEN)); while ((entryPtr = TclOSreaddir(d)) != NULL) { /* INTL: Native. */ Tcl_DString utfDs; CONST char *utfname; /* * Skip this file if it doesn't agree with the hidden parameters * requested by the user (via -type or pattern). */ if (*entryPtr->d_name == '.') { if (!matchHidden) continue; } else { #ifdef MAC_OSX_TCL if (matchHiddenPat) continue; /* Also need to check HFS hidden flag in TclMacOSXMatchType. */ #else if (matchHidden) continue; #endif } /* * Now check to see if the file matches, according to both type * and pattern. If so, add the file to the result. */ utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, &utfDs); if (Tcl_StringCaseMatch(utfname, pattern, 0)) { int typeOk = 1; if (types != NULL) { Tcl_DStringSetLength(&ds, nativeDirLen); native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1); matchResult = NativeMatchType(interp, native, entryPtr->d_name, types); typeOk = (matchResult == 1); } if (typeOk) { Tcl_ListObjAppendElement(interp, resultPtr, TclNewFSPathObj(pathPtr, utfname, Tcl_DStringLength(&utfDs))); } } Tcl_DStringFree(&utfDs); if (matchResult < 0) { break; } } closedir(d); Tcl_DStringFree(&ds); Tcl_DStringFree(&dsOrig); Tcl_DecrRefCount(fileNamePtr); } if (matchResult < 0) { return TCL_ERROR; } else { return TCL_OK; } }
static int ConfigureScale( Tcl_Interp *interp, /* Used for error reporting. */ register TkScale *scalePtr, /* Information about widget; may or may not * already have values for some fields. */ int objc, /* Number of valid entries in objv. */ Tcl_Obj *const objv[]) /* Argument values. */ { Tk_SavedOptions savedOptions; Tcl_Obj *errorResult = NULL; int error; double varValue; /* * Eliminate any existing trace on a variable monitored by the scale. */ if (scalePtr->varNamePtr != NULL) { Tcl_UntraceVar(interp, Tcl_GetString(scalePtr->varNamePtr), TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, ScaleVarProc, scalePtr); } for (error = 0; error <= 1; error++) { if (!error) { /* * First pass: set options to new values. */ if (Tk_SetOptions(interp, (char *) scalePtr, scalePtr->optionTable, objc, objv, scalePtr->tkwin, &savedOptions, NULL) != TCL_OK) { continue; } } else { /* * Second pass: restore options to old values. */ errorResult = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errorResult); Tk_RestoreSavedOptions(&savedOptions); } /* * If the scale is tied to the value of a variable, then set the * scale's value from the value of the variable, if it exists and it * holds a valid double value. */ if (scalePtr->varNamePtr != NULL) { double value; Tcl_Obj *valuePtr; valuePtr = Tcl_ObjGetVar2(interp, scalePtr->varNamePtr, NULL, TCL_GLOBAL_ONLY); if ((valuePtr != NULL) && (Tcl_GetDoubleFromObj(NULL, valuePtr, &value) == TCL_OK)) { scalePtr->value = TkRoundToResolution(scalePtr, value); } } /* * Several options need special processing, such as parsing the * orientation and creating GCs. */ scalePtr->fromValue = TkRoundToResolution(scalePtr, scalePtr->fromValue); scalePtr->toValue = TkRoundToResolution(scalePtr, scalePtr->toValue); scalePtr->tickInterval = TkRoundToResolution(scalePtr, scalePtr->tickInterval); /* * Make sure that the tick interval has the right sign so that * addition moves from fromValue to toValue. */ if ((scalePtr->tickInterval < 0) ^ ((scalePtr->toValue - scalePtr->fromValue) < 0)) { scalePtr->tickInterval = -scalePtr->tickInterval; } ComputeFormat(scalePtr); scalePtr->labelLength = scalePtr->label ? (int)strlen(scalePtr->label) : 0; Tk_SetBackgroundFromBorder(scalePtr->tkwin, scalePtr->bgBorder); if (scalePtr->highlightWidth < 0) { scalePtr->highlightWidth = 0; } scalePtr->inset = scalePtr->highlightWidth + scalePtr->borderWidth; break; } if (!error) { Tk_FreeSavedOptions(&savedOptions); } /* * Set the scale value to itself; all this does is to make sure that the * scale's value is within the new acceptable range for the scale. We * don't set the var here because we need to make special checks for * possibly changed varNamePtr. */ TkScaleSetValue(scalePtr, scalePtr->value, 0, 1); /* * Reestablish the variable trace, if it is needed. */ if (scalePtr->varNamePtr != NULL) { Tcl_Obj *valuePtr; /* * Set the associated variable only when the new value differs from * the current value, or the variable doesn't yet exist. */ valuePtr = Tcl_ObjGetVar2(interp, scalePtr->varNamePtr, NULL, TCL_GLOBAL_ONLY); if ((valuePtr == NULL) || (Tcl_GetDoubleFromObj(NULL, valuePtr, &varValue) != TCL_OK)) { ScaleSetVariable(scalePtr); } else { char varString[TCL_DOUBLE_SPACE], scaleString[TCL_DOUBLE_SPACE]; sprintf(varString, scalePtr->format, varValue); sprintf(scaleString, scalePtr->format, scalePtr->value); if (strcmp(varString, scaleString)) { ScaleSetVariable(scalePtr); } } Tcl_TraceVar(interp, Tcl_GetString(scalePtr->varNamePtr), TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, ScaleVarProc, scalePtr); } ScaleWorldChanged(scalePtr); if (error) { Tcl_SetObjResult(interp, errorResult); Tcl_DecrRefCount(errorResult); return TCL_ERROR; } return TCL_OK; }
static int wlog_get_publishlog_lines(Tcl_Interp *interpreter, int fd, uint32 start, uint32 end, Tcl_Obj **ret_list) { Tcl_Obj *list = NULL; Tcl_Obj *line_obj = NULL; tstring *line_buf = NULL; char buf[wlog_log_buf_size]; uint32 cur_line = 0; uint32 seg_start = 0; uint32 i = 0; int count = 0; int err = 0; char *cp; bail_null(ret_list); list = Tcl_NewListObj(0, NULL); bail_null(list); do { if (cur_line + 1 >= end) { break; } errno = 0; count = read(fd, buf, wlog_log_buf_size); if (count == -1 && errno == EINTR) { continue; } bail_require_errno(count >= 0, I_("Reading log file '%s'"), file_publishlog_path); while (( cp = memchr(buf, '\0' , count )) != NULL ) *cp = ' '; while (( cp = memchr(buf, '<' , count )) != NULL ) *cp = '['; while (( cp = memchr(buf, '>' , count )) != NULL ) *cp = ']'; /* look for a newline inside the buffer */ seg_start = 0; for (i = 0; i < (uint32)count; ++i) { if (buf[i] == '\n') { if (cur_line + 1 >= start && cur_line + 1 < end) { if (!line_buf) { err = ts_new(&line_buf); bail_error(err); } err = ts_append_str_frag(line_buf, buf, seg_start, i - seg_start); bail_error(err); line_obj = Tcl_NewStringObj(ts_str(line_buf), ts_length(line_buf)); bail_null(line_obj); err = Tcl_ListObjAppendElement(interpreter, list, line_obj); bail_require(err == TCL_OK); err = 0; ts_free(&line_buf); } seg_start = i + 1; ++cur_line; } } if (seg_start < (uint32)count) { if (cur_line + 1 >= start && cur_line + 1 < end) { if (!line_buf) { err = ts_new(&line_buf); bail_error(err); } err = ts_append_str_frag(line_buf, buf, seg_start, (uint32)count - seg_start); bail_error(err); } } } while (count > 0); *ret_list = list; list = NULL; bail: if (list) { Tcl_DecrRefCount(list); } ts_free(&line_buf); return(err); }
/* * putchan_raw <server_tag> <#chan> <text> * Use this instead of putserv so that can see own message * * "raw" because putchan in Tcl will do some string fixing on text * * all command parameters should be using unicode (internal) encoding. */ int putchan_raw(ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* const objv[]) { (void) clientData; if (objc != 4) { Tcl_Obj* str = Tcl_ObjPrintf("wrong # args: should be \"putchan_raw" " server_tag channel text\""); Tcl_SetObjResult(interp, str); return TCL_ERROR; } Tcl_Obj* const server_tag = objv[1]; Tcl_Obj* const target = objv[2]; Tcl_Obj* const msg = objv[3]; // find the server in Irssi. SERVER_REC* server_rec = server_find_tag(Tcl_GetString(server_tag)); if (server_rec == NULL) { Tcl_Obj* str = Tcl_ObjPrintf("server with tag '%s' not found", Tcl_GetString(server_tag)); Tcl_SetObjResult(interp, str); return TCL_ERROR; } // find the channel on this server in Irssi. CHANNEL_REC* channel_rec = channel_find(server_rec, Tcl_GetString(target)); if (channel_rec == NULL) { Tcl_Obj* str = Tcl_ObjPrintf("channel '%s' not found on server '%s'", Tcl_GetString(target), Tcl_GetString(server_tag)); Tcl_SetObjResult(interp, str); return TCL_ERROR; } // create the full command string to send to the IRC server. // PRIVMSG <target> :<msg> // this is how we used to create the command but I am concerned it // is not dealing with encoding correctly. //Tcl_Obj* send_str = Tcl_ObjPrintf("PRIVMSG %s :%s", target, msg); // try to be more careful with how we build the string. // -1 means take everything up to first NULL. Tcl_Obj* send_str = Tcl_NewStringObj("PRIVMSG ", -1); if (!send_str) { return TCL_ERROR; } Tcl_AppendObjToObj(send_str, target); Tcl_AppendToObj(send_str, " :", strlen(" :")); Tcl_AppendObjToObj(send_str, msg); // send the command to the server. // from ByteArrObj docs: // "Obtaining the string representation of a byte-array object (by calling Tcl_GetStringFromObj) produces a properly formed UTF-8 sequence with a one-to-one mapping between the bytes in the internal representation and the UTF-8 characters in the string representation." irc_send_cmd((IRC_SERVER_REC*) server_rec, Tcl_GetString(send_str)); // this frees the object. unsure if I actually need to call this, but it // seems like it doesn't matter if I do! Tcl_DecrRefCount(send_str); // write the message to Irssi so we see it ourselves. print_message_public(server_rec, channel_rec, Tcl_GetString(target), server_rec->nick, NULL, Tcl_GetString(msg)); //signal_emit("message own_public", 3, server, text, chan); return TCL_OK; }
static int HandleTclCommand( ClientData clientData, /* Information about command to execute. */ int offset, /* Return selection bytes starting at this * offset. */ char *buffer, /* Place to store converted selection. */ int maxBytes) /* Maximum # of bytes to store at buffer. */ { CommandInfo *cmdInfoPtr = clientData; int length; Tcl_Obj *command; const char *string; Tcl_Interp *interp = cmdInfoPtr->interp; Tcl_InterpState savedState; int extraBytes, charOffset, count, numChars, code; const char *p; /* * We must also protect the interpreter and the command from being deleted * too soon. */ Tcl_Preserve(clientData); Tcl_Preserve(interp); /* * Compute the proper byte offset in the case where the last chunk split a * character. */ if (offset == cmdInfoPtr->byteOffset) { charOffset = cmdInfoPtr->charOffset; extraBytes = strlen(cmdInfoPtr->buffer); if (extraBytes > 0) { strcpy(buffer, cmdInfoPtr->buffer); maxBytes -= extraBytes; buffer += extraBytes; } } else { cmdInfoPtr->byteOffset = 0; cmdInfoPtr->charOffset = 0; extraBytes = 0; charOffset = 0; } /* * First, generate a command by taking the command string and appending * the offset and maximum # of bytes. */ command = Tcl_ObjPrintf("%s %d %d", cmdInfoPtr->command, charOffset, maxBytes); Tcl_IncrRefCount(command); /* * Execute the command. Be sure to restore the state of the interpreter * after executing the command. */ savedState = Tcl_SaveInterpState(interp, TCL_OK); code = Tcl_EvalObjEx(interp, command, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(command); if (code == TCL_OK) { /* * TODO: This assumes that bytes are characters; that's not true! */ string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); count = (length > maxBytes) ? maxBytes : length; memcpy(buffer, string, (size_t) count); buffer[count] = '\0'; /* * Update the partial character information for the next retrieval if * the command has not been deleted. */ if (cmdInfoPtr->interp != NULL) { if (length <= maxBytes) { cmdInfoPtr->charOffset += Tcl_NumUtfChars(string, -1); cmdInfoPtr->buffer[0] = '\0'; } else { p = string; string += count; numChars = 0; while (p < string) { p = Tcl_UtfNext(p); numChars++; } cmdInfoPtr->charOffset += numChars; length = p - string; if (length > 0) { strncpy(cmdInfoPtr->buffer, string, (size_t) length); } cmdInfoPtr->buffer[length] = '\0'; } cmdInfoPtr->byteOffset += count + extraBytes; } count += extraBytes; } else { /* * Something went wrong. Log errors as background errors, and silently * drop everything else. */ if (code == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (command handling selection)"); Tcl_BackgroundException(interp, code); } count = -1; } (void) Tcl_RestoreInterpState(interp, savedState); Tcl_Release(clientData); Tcl_Release(interp); return count; }
static int TextToPostscript( Tcl_Interp *interp, /* Leave Postscript or error message here. */ Tk_Canvas canvas, /* Information about overall canvas. */ Tk_Item *itemPtr, /* Item for which Postscript is wanted. */ int prepass) /* 1 means this is a prepass to collect font * information; 0 means final Postscript is * being created. */ { TextItem *textPtr = (TextItem *) itemPtr; double x, y; Tk_FontMetrics fm; const char *justify; XColor *color; Pixmap stipple; Tk_State state = itemPtr->state; Tcl_Obj *psObj; Tcl_InterpState interpState; if (state == TK_STATE_NULL) { state = Canvas(canvas)->canvas_state; } color = textPtr->color; stipple = textPtr->stipple; if (state == TK_STATE_HIDDEN || textPtr->color == NULL || textPtr->text == NULL || *textPtr->text == 0) { return TCL_OK; } else if (Canvas(canvas)->currentItemPtr == itemPtr) { if (textPtr->activeColor != NULL) { color = textPtr->activeColor; } if (textPtr->activeStipple != None) { stipple = textPtr->activeStipple; } } else if (state == TK_STATE_DISABLED) { if (textPtr->disabledColor != NULL) { color = textPtr->disabledColor; } if (textPtr->disabledStipple != None) { stipple = textPtr->disabledStipple; } } /* * Make our working space. */ psObj = Tcl_NewObj(); interpState = Tcl_SaveInterpState(interp, TCL_OK); /* * Generate postscript. */ Tcl_ResetResult(interp); if (Tk_CanvasPsFont(interp, canvas, textPtr->tkfont) != TCL_OK) { goto error; } Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp)); if (prepass != 0) { goto done; } Tcl_ResetResult(interp); if (Tk_CanvasPsColor(interp, canvas, color) != TCL_OK) { goto error; } Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp)); if (stipple != None) { Tcl_ResetResult(interp); Tk_CanvasPsStipple(interp, canvas, stipple); Tcl_AppendPrintfToObj(psObj, "/StippleText {\n %s} bind def\n", Tcl_GetString(Tcl_GetObjResult(interp))); } x = 0; y = 0; justify = NULL; /* lint. */ switch (textPtr->anchor) { case TK_ANCHOR_NW: x = 0; y = 0; break; case TK_ANCHOR_N: x = 1; y = 0; break; case TK_ANCHOR_NE: x = 2; y = 0; break; case TK_ANCHOR_E: x = 2; y = 1; break; case TK_ANCHOR_SE: x = 2; y = 2; break; case TK_ANCHOR_S: x = 1; y = 2; break; case TK_ANCHOR_SW: x = 0; y = 2; break; case TK_ANCHOR_W: x = 0; y = 1; break; case TK_ANCHOR_CENTER: x = 1; y = 1; break; } switch (textPtr->justify) { case TK_JUSTIFY_LEFT: justify = "0"; break; case TK_JUSTIFY_CENTER: justify = "0.5"; break; case TK_JUSTIFY_RIGHT: justify = "1"; break; } Tk_GetFontMetrics(textPtr->tkfont, &fm); Tcl_AppendPrintfToObj(psObj, "%.15g %.15g %.15g [\n", textPtr->angle, textPtr->x, Tk_CanvasPsY(canvas, textPtr->y)); Tcl_ResetResult(interp); Tk_TextLayoutToPostscript(interp, textPtr->textLayout); Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp)); Tcl_AppendPrintfToObj(psObj, "] %d %g %g %s %s DrawText\n", fm.linespace, x / -2.0, y / 2.0, justify, ((stipple == None) ? "false" : "true")); /* * Plug the accumulated postscript back into the result. */ done: (void) Tcl_RestoreInterpState(interp, interpState); Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj); Tcl_DecrRefCount(psObj); return TCL_OK; error: Tcl_DiscardInterpState(interpState); Tcl_DecrRefCount(psObj); return TCL_ERROR; }