static int TestwinclockCmd( ClientData dummy, /* Unused */ Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Argument count */ Tcl_Obj *const objv[]) /* Argument vector */ { static const FILETIME posixEpoch = { 0xD53E8000, 0x019DB1DE }; /* The Posix epoch, expressed as a Windows * FILETIME */ Tcl_Time tclTime; /* Tcl clock */ FILETIME sysTime; /* System clock */ Tcl_Obj *result; /* Result of the command */ LARGE_INTEGER t1, t2; LARGE_INTEGER p1, p2; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, ""); return TCL_ERROR; } QueryPerformanceCounter(&p1); Tcl_GetTime(&tclTime); GetSystemTimeAsFileTime(&sysTime); t1.LowPart = posixEpoch.dwLowDateTime; t1.HighPart = posixEpoch.dwHighDateTime; t2.LowPart = sysTime.dwLowDateTime; t2.HighPart = sysTime.dwHighDateTime; t2.QuadPart -= t1.QuadPart; QueryPerformanceCounter(&p2); result = Tcl_NewObj(); Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int) (t2.QuadPart / 10000000))); Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int) ((t2.QuadPart / 10) % 1000000))); Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.sec)); Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.usec)); Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p1.QuadPart)); Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p2.QuadPart)); Tcl_SetObjResult(interp, result); return TCL_OK; }
int sqlite3OutstandingMallocs(Tcl_Interp *interp){ void *p; Tcl_Obj *pRes = Tcl_NewObj(); Tcl_IncrRefCount(pRes); for(p=sqlite3_pFirst; p; p=((void **)p)[1]){ Tcl_Obj *pEntry = Tcl_NewObj(); Tcl_Obj *pStack = Tcl_NewObj(); char *z; u32 iLine; int nBytes = sqlite3OsAllocationSize(p) - TESTALLOC_OVERHEAD; char *zAlloc = (char *)p; int i; Tcl_ListObjAppendElement(0, pEntry, Tcl_NewIntObj(nBytes)); z = &zAlloc[TESTALLOC_OFFSET_FILENAME(p)]; Tcl_ListObjAppendElement(0, pEntry, Tcl_NewStringObj(z, -1)); z = &zAlloc[TESTALLOC_OFFSET_LINENUMBER(p)]; memcpy(&iLine, z, sizeof(u32)); Tcl_ListObjAppendElement(0, pEntry, Tcl_NewIntObj(iLine)); z = &zAlloc[TESTALLOC_OFFSET_USER(p)]; Tcl_ListObjAppendElement(0, pEntry, Tcl_NewStringObj(z, -1)); z = &zAlloc[TESTALLOC_OFFSET_STACK(p)]; for(i=0; i<TESTALLOC_STACKFRAMES; i++){ char zHex[128]; sprintf(zHex, "%p", ((void **)z)[i]); Tcl_ListObjAppendElement(0, pStack, Tcl_NewStringObj(zHex, -1)); } Tcl_ListObjAppendElement(0, pEntry, pStack); Tcl_ListObjAppendElement(0, pRes, pEntry); } Tcl_ResetResult(interp); Tcl_SetObjResult(interp, pRes); Tcl_DecrRefCount(pRes); return TCL_OK; }
static int PrefixAllObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int tableObjc, result, t, length, elemLength; const char *string, *elemString; Tcl_Obj **tableObjv, *resultPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "table string"); return TCL_ERROR; } result = Tcl_ListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); if (result != TCL_OK) { return result; } resultPtr = Tcl_NewListObj(0, NULL); string = Tcl_GetStringFromObj(objv[2], &length); for (t = 0; t < tableObjc; t++) { elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); /* * A prefix cannot match if it is longest. */ if (length <= elemLength) { if (TclpUtfNcmp2(elemString, string, length) == 0) { Tcl_ListObjAppendElement(interp, resultPtr, tableObjv[t]); } } } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; }
/* $pw panes -- * Return list of managed panes. */ static int PanedPanesCommand( void *recordPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Paned *pw = recordPtr; Ttk_Manager *mgr = pw->paned.mgr; Tcl_Obj *panes; int i; if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, ""); return TCL_ERROR; } panes = Tcl_NewListObj(0, NULL); for (i = 0; i < Ttk_NumberSlaves(mgr); ++i) { const char *pathName = Tk_PathName(Ttk_SlaveWindow(mgr,i)); Tcl_ListObjAppendElement(interp, panes, Tcl_NewStringObj(pathName,-1)); } Tcl_SetObjResult(interp, panes); return TCL_OK; }
static int gdb_reggrouplist (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj **objv) { struct reggroup *group; int i = 0; if (objc != 0) { Tcl_WrongNumArgs (interp, 0, objv, "gdb_reginfo grouplist"); return TCL_ERROR; } for (group = reggroup_next (get_current_arch (), NULL); group != NULL; group = reggroup_next (get_current_arch (), group)) { if (reggroup_type (group) == USER_REGGROUP) Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewStringObj (reggroup_name (group), -1)); } return TCL_OK; }
static int msg_filenames(Tcl_Interp *interp, notmuch_message_t *msg, int argc, const char *argv[]) { if (argc != 0) { tcl_result_printf(interp, "msg filenames takes no arguments"); return TCL_ERROR; } Tcl_Obj* list = Tcl_NewListObj(0, NULL); if (!list) { return TCL_ERROR; } notmuch_filenames_t *fns = notmuch_message_get_filenames(msg); while (notmuch_filenames_valid(fns)) { const char *fn = notmuch_filenames_get(fns); Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fn, -1)); notmuch_filenames_move_to_next(fns); } notmuch_filenames_destroy(fns); Tcl_SetObjResult(interp, list); return TCL_OK; }
/*----------------------------------------------------------------------------- * ReturnSelectedFileList -- * * Take the resulting file descriptor sets from a select, and the * list of file descritpors and build up a list of Tcl file handles. * * Parameters: * o fileDescSetPtr (I) - The select fd_set. * o fileDescCnt (I) - Number of descriptors in the list. * o channelListPtr (I) - A pointer to a list of the FILE pointers for * files that are in the set. * Returns: * List of file handles. *----------------------------------------------------------------------------- */ static Tcl_Obj * ReturnSelectedFileList (fd_set *fileDescSetPtr, int fileDescCnt, channelData_t *channelList) { int idx, handleCnt; Tcl_Obj *fileHandleList = Tcl_NewListObj (0, NULL); handleCnt = 0; for (idx = 0; idx < fileDescCnt; idx++) { if (((channelList [idx].readFd >= 0) && FD_ISSET (channelList [idx].readFd, fileDescSetPtr)) || ((channelList [idx].writeFd >= 0) && FD_ISSET (channelList [idx].writeFd, fileDescSetPtr))) { Tcl_ListObjAppendElement (NULL, fileHandleList, channelList [idx].channelIdObj); handleCnt++; } } return fileHandleList; }
int proxenet_tcl_load_file(plugin_t* plugin) { char* pathname; Tcl_Interp* tcl_interpreter; Tcl_Obj* tcl_cmds_ptr; if(plugin->state != INACTIVE){ #ifdef DEBUG if(cfg->verbose > 2) xlog_tcl(LOG_DEBUG, "Plugin '%s' is already loaded. Skipping...\n", plugin->name); #endif return 0; } pathname = plugin->fullpath; tcl_interpreter = (Tcl_Interp*) plugin->interpreter->vm; if (Tcl_EvalFile (tcl_interpreter, pathname) != TCL_OK){ xlog_tcl(LOG_ERROR, "Failed to load '%s'\n", pathname); return -1; } plugin->interpreter->vm = tcl_interpreter; plugin->interpreter->ready = true; tcl_cmds_ptr = Tcl_NewListObj (0, NULL); Tcl_IncrRefCount(tcl_cmds_ptr); Tcl_ListObjAppendElement(tcl_interpreter, tcl_cmds_ptr, Tcl_NewStringObj(CFG_ONLEAVE_PLUGIN_FUNCTION, -1)); if (Tcl_EvalObjEx(tcl_interpreter, tcl_cmds_ptr, TCL_EVAL_DIRECT) != TCL_OK) { xlog_tcl(LOG_WARNING, "%s() failed to execute properly\n", CFG_ONLOAD_PLUGIN_FUNCTION); } Tcl_DecrRefCount(tcl_cmds_ptr); return 0; }
/* ARGSUSED */ int Tcl_PidObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ { if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); return TCL_ERROR; } if (objc == 1) { Tcl_SetObjResult(interp, Tcl_NewLongObj((long) getpid())); } else { Tcl_Channel chan; const Tcl_ChannelType *chanTypePtr; PipeState *pipePtr; int i; Tcl_Obj *resultPtr, *longObjPtr; chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } chanTypePtr = Tcl_GetChannelType(chan); if (chanTypePtr != &pipeChannelType) { return TCL_OK; } pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); resultPtr = Tcl_NewObj(); for (i = 0; i < pipePtr->numPids; i++) { longObjPtr = Tcl_NewLongObj((long) TclpGetPid(pipePtr->pidPtr[i])); Tcl_ListObjAppendElement(NULL, resultPtr, longObjPtr); } Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; }
int proxenet_tcl_destroy_plugin(plugin_t* plugin) { Tcl_Interp* tcl_interpreter; Tcl_Obj* tcl_cmds_ptr; tcl_interpreter = (Tcl_Interp*)plugin->interpreter->vm; proxenet_plugin_set_state(plugin, INACTIVE); tcl_cmds_ptr = Tcl_NewListObj (0, NULL); Tcl_IncrRefCount(tcl_cmds_ptr); Tcl_ListObjAppendElement(tcl_interpreter, tcl_cmds_ptr, Tcl_NewStringObj(CFG_ONLEAVE_PLUGIN_FUNCTION, -1)); if (Tcl_EvalObjEx(tcl_interpreter, tcl_cmds_ptr, TCL_EVAL_DIRECT) != TCL_OK) { xlog_tcl(LOG_WARNING, "%s() failed to execute properly\n", CFG_ONLEAVE_PLUGIN_FUNCTION); } Tcl_DecrRefCount(tcl_cmds_ptr); plugin->pre_function = NULL; plugin->post_function = NULL; return 0; }
SEXP RTcl_ObjFromIntVector(SEXP args) { int count; Tcl_Obj *tclobj, *elem; int i; SEXP val, drop; val = CADR(args); drop = CADDR(args); tclobj = Tcl_NewObj(); count = length(val); if (count == 1 && LOGICAL(drop)[0]) tclobj = Tcl_NewIntObj(INTEGER(val)[0]); else for ( i = 0 ; i < count ; i++) { elem = Tcl_NewIntObj(INTEGER(val)[i]); Tcl_ListObjAppendElement(RTcl_interp, tclobj, elem); } return makeRTclObject(tclobj); }
static int getIDs( Tcl_Interp *interp, int objc, Tcl_Obj * const objv[], CanvasParams *param, GPtrArray *items ) { if( objc != 3 ) { Tcl_WrongNumArgs( interp, 2, objv, NULL ); return TCL_ERROR; } if( items != NULL && items->len > 0 ) { int k; Tcl_Obj *resList = Tcl_NewListObj( 0, NULL ); for( k = 0; k < items->len; ++k ) { Gnocl_CanvasItemInfo *info = GET_INFO( items, k ); Tcl_ListObjAppendElement( interp, resList, Tcl_NewIntObj( info->id ) ); } Tcl_SetObjResult( interp, resList ); } return TCL_OK; }
static Tcl_Obj *PrologToTclObj(AP_World *w, AP_Obj prolog_obj, Tcl_Interp *interp) { Tcl_Obj *tcl_obj; AP_Obj i; switch (AP_ObjType(w, prolog_obj)) { case AP_INTEGER: tcl_obj = Tcl_NewIntObj(AP_GetLong(w, prolog_obj)); break; case AP_FLOAT: tcl_obj = Tcl_NewDoubleObj(AP_GetDouble(w, prolog_obj)); break; case AP_ATOM: if (AP_IsNullList(w, prolog_obj)) { tcl_obj = Tcl_NewStringObj((char *)"", -1); } else { tcl_obj = Tcl_NewStringObj((char *)AP_GetAtomStr(w, prolog_obj), -1); } break; case AP_LIST: tcl_obj = Tcl_NewListObj(0, NULL); for (i = prolog_obj; !AP_IsNullList(w, i); i = AP_ListTail(w, i)) { Tcl_ListObjAppendElement(interp, tcl_obj, PrologToTclObj(w, AP_ListHead(w, i), interp)); } break; case AP_STRUCTURE: tcl_obj = Tcl_NewStringObj((char *)"structure", -1); break; case AP_VARIABLE: tcl_obj = Tcl_NewStringObj((char *)"variable", -1); break; default: tcl_obj = NULL; } return tcl_obj; }
static int ForeachAssignments (Tcl_Interp * const interp, ForeachState * const statePtr, Tcl_Obj * const varPtr, DBFHandle const dbfHandle) { Tcl_Obj *const valuePtr = Tcl_NewObj (); int const i = statePtr->i; int j; int const size = statePtr->size; for (j = 0; j < size; j++) { if (Tcl_ListObjAppendElement (interp, valuePtr, NewAttributeObj (dbfHandle, i, j)) != TCL_OK) { return TCL_ERROR; } } if (Tcl_ObjSetVar2 (interp, varPtr, NULL, valuePtr, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } return TCL_OK; }
static void freeTile (HtmlImage2 *pImage) { HtmlTree *pTree = pImage->pImageServer->pTree; int flags = TCL_GLOBAL_ONLY; Tcl_Obj *pScript; if (pImage->pTileName) { pScript = Tcl_NewStringObj("image delete", -1); Tcl_IncrRefCount(pScript); Tcl_ListObjAppendElement(0, pScript, pImage->pTileName); Tcl_EvalObjEx(pTree->interp, pScript, flags); Tcl_DecrRefCount(pScript); Tcl_DecrRefCount(pImage->pTileName); pImage->tile = 0; pImage->pTileName = 0; } if (pImage->tilepixmap) { assert(pImage->pixmap); Tk_FreePixmap( Tk_Display(pImage->pImageServer->pTree->tkwin), pImage->tilepixmap); pImage->tilepixmap = 0; } }
static void get_register_name (int regnum, map_arg arg) { /* Non-zero if the caller wants the register numbers, too. */ int numbers = arg.integer; Tcl_Obj *name = Tcl_NewStringObj (gdbarch_register_name (get_current_arch (), regnum), -1); Tcl_Obj *elt; if (numbers) { /* Build a tuple of the form "{REGNAME NUMBER}", and append it to our result. */ Tcl_Obj *array[2]; array[0] = name; array[1] = Tcl_NewIntObj (regnum); elt = Tcl_NewListObj (2, array); } else elt = name; Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, elt); }
static int tclvarFilter( sqlite3_vtab_cursor *pVtabCursor, int idxNum, const char *idxStr, int argc, sqlite3_value **argv ){ tclvar_cursor *pCur = (tclvar_cursor *)pVtabCursor; Tcl_Interp *interp = ((tclvar_vtab *)(pVtabCursor->pVtab))->interp; Tcl_Obj *p = Tcl_NewStringObj("info vars", -1); Tcl_IncrRefCount(p); assert( argc==0 || argc==1 ); if( argc==1 ){ Tcl_Obj *pArg = Tcl_NewStringObj((char*)sqlite3_value_text(argv[0]), -1); Tcl_ListObjAppendElement(0, p, pArg); } Tcl_EvalObjEx(interp, p, TCL_EVAL_GLOBAL); pCur->pList1 = Tcl_GetObjResult(interp); Tcl_IncrRefCount(pCur->pList1); assert( pCur->i1==0 && pCur->i2==0 && pCur->pList2==0 ); Tcl_DecrRefCount(p); return tclvarNext(pVtabCursor); }
/* discover the sequencer devices currently available */ static int alsa_sequencer_list(ClientData clientData, Tcl_Interp *interp) { snd_seq_client_info_t *cinfo; snd_seq_port_info_t *pinfo; Tcl_Obj *result = Tcl_NewListObj(0, NULL); if (init_seq(clientData, interp) != TCL_OK) { return TCL_ERROR; } snd_seq_client_info_alloca(&cinfo); snd_seq_port_info_alloca(&pinfo); snd_seq_client_info_set_client(cinfo, -1); while (snd_seq_query_next_client(seq, cinfo) >= 0) { int client = snd_seq_client_info_get_client(cinfo); snd_seq_port_info_set_client(pinfo, client); snd_seq_port_info_set_port(pinfo, -1); while (snd_seq_query_next_port(seq, pinfo) >= 0) { /* we need both READ and SUBS_READ */ int capability = snd_seq_port_info_get_capability(pinfo); char *readable = ((capability & (SND_SEQ_PORT_CAP_READ | SND_SEQ_PORT_CAP_SUBS_READ)) == (SND_SEQ_PORT_CAP_READ | SND_SEQ_PORT_CAP_SUBS_READ)) ? "r" : ""; char *writable = ((capability & (SND_SEQ_PORT_CAP_WRITE | SND_SEQ_PORT_CAP_SUBS_WRITE)) == (SND_SEQ_PORT_CAP_WRITE | SND_SEQ_PORT_CAP_SUBS_WRITE)) ? "w" : ""; Tcl_Obj *element = Tcl_ObjPrintf("%3d:%-3d %-32.32s %s %s%s", snd_seq_port_info_get_client(pinfo), snd_seq_port_info_get_port(pinfo), snd_seq_client_info_get_name(cinfo), snd_seq_port_info_get_name(pinfo), readable, writable); Tcl_ListObjAppendElement(interp, result, element); } } Tcl_SetObjResult(interp, result); return TCL_OK; }
/* 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 = TclGetStringFromObj(commandPtr, &length); for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { tempCommand = TclGetStringFromObj(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; }
static int ConsoleObjCmd( ClientData clientData, /* Access to the console interp */ Tcl_Interp *interp, /* Current interpreter */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument objects */ { int index, result; static const char *const options[] = {"eval", "hide", "show", "title", NULL}; enum option {CON_EVAL, CON_HIDE, CON_SHOW, CON_TITLE}; Tcl_Obj *cmd = NULL; ConsoleInfo *info = (ConsoleInfo *) clientData; Tcl_Interp *consoleInterp = info->consoleInterp; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum option) index) { case CON_EVAL: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "script"); return TCL_ERROR; } cmd = objv[2]; break; case CON_HIDE: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } cmd = Tcl_NewStringObj("wm withdraw .", -1); break; case CON_SHOW: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } cmd = Tcl_NewStringObj("wm deiconify .", -1); break; case CON_TITLE: if (objc > 3) { Tcl_WrongNumArgs(interp, 2, objv, "?title?"); return TCL_ERROR; } cmd = Tcl_NewStringObj("wm title .", -1); if (objc == 3) { Tcl_ListObjAppendElement(NULL, cmd, objv[2]); } break; } Tcl_IncrRefCount(cmd); if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) { Tcl_Preserve(consoleInterp); result = Tcl_GlobalEvalObj(consoleInterp, cmd); Tcl_SetReturnOptions(interp, Tcl_GetReturnOptions(consoleInterp, result)); Tcl_SetObjResult(interp, Tcl_GetObjResult(consoleInterp)); Tcl_Release(consoleInterp); } else { Tcl_AppendResult(interp, "no active console interp", NULL); result = TCL_ERROR; } Tcl_DecrRefCount(cmd); return result; }
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 = Tcl_FSGetNativePath(pathPtr); tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL); nativeTail = 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, nativeDirLen; int matchHidden, matchHiddenPat; Tcl_StatBuf statBuf; Tcl_DString ds; /* native encoding of dir */ Tcl_DString dsOrig; /* utf-8 encoding of dir */ Tcl_DStringInit(&dsOrig); dirName = TclGetStringFromObj(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 = TclDStringAppendLiteral(&dsOrig, "/"); 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_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read directory \"%s\": %s", Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp))); } 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; } return TCL_OK; }
static int PrefixMatchObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int flags = 0, result, index; int dummyLength, i, errorLength; Tcl_Obj *errorPtr = NULL; const char *message = "option"; Tcl_Obj *tablePtr, *objPtr, *resultPtr; static const char *const matchOptions[] = { "-error", "-exact", "-message", NULL }; enum matchOptions { PRFMATCH_ERROR, PRFMATCH_EXACT, PRFMATCH_MESSAGE }; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? table string"); return TCL_ERROR; } for (i = 1; i < (objc - 2); i++) { if (Tcl_GetIndexFromObj(interp, objv[i], matchOptions, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum matchOptions) index) { case PRFMATCH_EXACT: flags |= TCL_EXACT; break; case PRFMATCH_MESSAGE: if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing value for -message", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL); return TCL_ERROR; } i++; message = Tcl_GetString(objv[i]); break; case PRFMATCH_ERROR: if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing value for -error", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL); return TCL_ERROR; } i++; result = Tcl_ListObjLength(interp, objv[i], &errorLength); if (result != TCL_OK) { return TCL_ERROR; } if ((errorLength % 2) != 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "error options must have an even number of elements", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); return TCL_ERROR; } errorPtr = objv[i]; break; } } tablePtr = objv[objc - 2]; objPtr = objv[objc - 1]; /* * Check that table is a valid list first, since we want to handle that * error case regardless of level. */ result = Tcl_ListObjLength(interp, tablePtr, &dummyLength); if (result != TCL_OK) { return result; } result = GetIndexFromObjList(interp, objPtr, tablePtr, message, flags, &index); if (result != TCL_OK) { if (errorPtr != NULL && errorLength == 0) { Tcl_ResetResult(interp); return TCL_OK; } else if (errorPtr == NULL) { return TCL_ERROR; } if (Tcl_IsShared(errorPtr)) { errorPtr = Tcl_DuplicateObj(errorPtr); } Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewStringObj("-code", 5)); Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewIntObj(result)); return Tcl_SetReturnOptions(interp, errorPtr); } result = Tcl_ListObjIndex(interp, tablePtr, index, &resultPtr); if (result != TCL_OK) { return result; } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; }
int TkGetInterpNames( Tcl_Interp *interp, /* Interpreter for returning a result. */ Tk_Window tkwin) /* Window whose display is to be used for the * lookup. */ { #ifndef TK_SEND_ENABLED_ON_WINDOWS /* * Temporarily disabled for bug #858822 */ return TCL_OK; #else /* TK_SEND_ENABLED_ON_WINDOWS */ LPRUNNINGOBJECTTABLE pROT = NULL; LPCOLESTR oleszStub = TKWINSEND_REGISTRATION_BASE; HRESULT hr = S_OK; Tcl_Obj *objList = NULL; int result = TCL_OK; hr = GetRunningObjectTable(0, &pROT); if (SUCCEEDED(hr)) { IBindCtx* pBindCtx = NULL; objList = Tcl_NewListObj(0, NULL); hr = CreateBindCtx(0, &pBindCtx); if (SUCCEEDED(hr)) { IEnumMoniker* pEnum; hr = pROT->lpVtbl->EnumRunning(pROT, &pEnum); if (SUCCEEDED(hr)) { IMoniker* pmk = NULL; while (pEnum->lpVtbl->Next(pEnum, 1, &pmk, NULL) == S_OK) { LPOLESTR olestr; hr = pmk->lpVtbl->GetDisplayName(pmk, pBindCtx, NULL, &olestr); if (SUCCEEDED(hr)) { IMalloc *pMalloc = NULL; if (wcsncmp(olestr, oleszStub, wcslen(oleszStub)) == 0) { LPOLESTR p = olestr + wcslen(oleszStub); if (*p) { result = Tcl_ListObjAppendElement(interp, objList, Tcl_NewUnicodeObj(p + 1, -1)); } } hr = CoGetMalloc(1, &pMalloc); if (SUCCEEDED(hr)) { pMalloc->lpVtbl->Free(pMalloc, (void*)olestr); pMalloc->lpVtbl->Release(pMalloc); } } pmk->lpVtbl->Release(pmk); } pEnum->lpVtbl->Release(pEnum); } pBindCtx->lpVtbl->Release(pBindCtx); } pROT->lpVtbl->Release(pROT); } if (FAILED(hr)) { /* * Expire the list if set. */ if (objList != NULL) { Tcl_DecrRefCount(objList); } Tcl_SetObjResult(interp, Win32ErrorObj(hr)); result = TCL_ERROR; } if (result == TCL_OK) { Tcl_SetObjResult(interp, objList); } return result; #endif /* TK_SEND_ENABLED_ON_WINDOWS */ }
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); }
static int wlog_get_fmsaccesslog_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_fmsaccesslog_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); }
int Tk_PlaceObjCmd( ClientData clientData, /* Interpreter main window. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tk_Window main_win = clientData; Tk_Window tkwin; Slave *slavePtr; TkDisplay *dispPtr; Tk_OptionTable optionTable; static const char *const optionStrings[] = { "configure", "forget", "info", "slaves", NULL }; enum options { PLACE_CONFIGURE, PLACE_FORGET, PLACE_INFO, PLACE_SLAVES }; int index; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "option|pathName args"); return TCL_ERROR; } /* * Create the option table for this widget class. If it has already been * created, the cached pointer will be returned. */ optionTable = Tk_CreateOptionTable(interp, optionSpecs); /* * Handle special shortcut where window name is first argument. */ if (Tcl_GetString(objv[1])[0] == '.') { if (TkGetWindowFromObj(interp, main_win, objv[1], &tkwin) != TCL_OK) { return TCL_ERROR; } /* * Initialize, if that hasn't been done yet. */ dispPtr = ((TkWindow *) tkwin)->dispPtr; if (!dispPtr->placeInit) { Tcl_InitHashTable(&dispPtr->masterTable, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(&dispPtr->slaveTable, TCL_ONE_WORD_KEYS); dispPtr->placeInit = 1; } return ConfigureSlave(interp, tkwin, optionTable, objc-2, objv+2); } /* * Handle more general case of option followed by window name followed by * possible additional arguments. */ if (TkGetWindowFromObj(interp, main_win, objv[2], &tkwin) != TCL_OK) { return TCL_ERROR; } /* * Initialize, if that hasn't been done yet. */ dispPtr = ((TkWindow *) tkwin)->dispPtr; if (!dispPtr->placeInit) { Tcl_InitHashTable(&dispPtr->masterTable, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(&dispPtr->slaveTable, TCL_ONE_WORD_KEYS); dispPtr->placeInit = 1; } if (Tcl_GetIndexFromObjStruct(interp, objv[1], optionStrings, sizeof(char *), "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { case PLACE_CONFIGURE: if (objc == 3 || objc == 4) { Tcl_Obj *objPtr; slavePtr = FindSlave(tkwin); if (slavePtr == NULL) { return TCL_OK; } objPtr = Tk_GetOptionInfo(interp, (char *) slavePtr, optionTable, (objc == 4) ? objv[3] : NULL, tkwin); if (objPtr == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, objPtr); return TCL_OK; } return ConfigureSlave(interp, tkwin, optionTable, objc-3, objv+3); case PLACE_FORGET: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "pathName"); return TCL_ERROR; } slavePtr = FindSlave(tkwin); if (slavePtr == NULL) { return TCL_OK; } if ((slavePtr->masterPtr != NULL) && (slavePtr->masterPtr->tkwin != Tk_Parent(slavePtr->tkwin))) { Tk_UnmaintainGeometry(slavePtr->tkwin, slavePtr->masterPtr->tkwin); } UnlinkSlave(slavePtr); Tcl_DeleteHashEntry(Tcl_FindHashEntry(&dispPtr->slaveTable, (char *) tkwin)); Tk_DeleteEventHandler(tkwin, StructureNotifyMask, SlaveStructureProc, slavePtr); Tk_ManageGeometry(tkwin, NULL, NULL); Tk_UnmapWindow(tkwin); FreeSlave(slavePtr); break; case PLACE_INFO: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "pathName"); return TCL_ERROR; } return PlaceInfoCommand(interp, tkwin); case PLACE_SLAVES: { Master *masterPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "pathName"); return TCL_ERROR; } masterPtr = FindMaster(tkwin); if (masterPtr != NULL) { Tcl_Obj *listPtr = Tcl_NewObj(); for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; slavePtr = slavePtr->nextPtr) { Tcl_ListObjAppendElement(NULL, listPtr, TkNewWindowObj(slavePtr->tkwin)); } Tcl_SetObjResult(interp, listPtr); } break; } } return TCL_OK; }
/* ** Implementation of a special SQL scalar function for testing tokenizers ** designed to be used in concert with the Tcl testing framework. This ** function must be called with two or more arguments: ** ** SELECT <function-name>(<key-name>, ..., <input-string>); ** ** where <function-name> is the name passed as the second argument ** to the sqlite3Fts3InitHashTable() function (e.g. 'fts3_tokenizer') ** concatenated with the string '_test' (e.g. 'fts3_tokenizer_test'). ** ** The return value is a string that may be interpreted as a Tcl ** list. For each token in the <input-string>, three elements are ** added to the returned list. The first is the token position, the ** second is the token text (folded, stemmed, etc.) and the third is the ** substring of <input-string> associated with the token. For example, ** using the built-in "simple" tokenizer: ** ** SELECT fts_tokenizer_test('simple', 'I don't see how'); ** ** will return the string: ** ** "{0 i I 1 dont don't 2 see see 3 how how}" ** */ static void testFunc( sqlite3_context *context, int argc, sqlite3_value **argv ){ Fts3Hash *pHash; sqlite3_tokenizer_module *p; sqlite3_tokenizer *pTokenizer = 0; sqlite3_tokenizer_cursor *pCsr = 0; const char *zErr = 0; const char *zName; int nName; const char *zInput; int nInput; const char *azArg[64]; const char *zToken; int nToken = 0; int iStart = 0; int iEnd = 0; int iPos = 0; int i; Tcl_Obj *pRet; if( argc<2 ){ sqlite3_result_error(context, "insufficient arguments", -1); return; } nName = sqlite3_value_bytes(argv[0]); zName = (const char *)sqlite3_value_text(argv[0]); nInput = sqlite3_value_bytes(argv[argc-1]); zInput = (const char *)sqlite3_value_text(argv[argc-1]); pHash = (Fts3Hash *)sqlite3_user_data(context); p = (sqlite3_tokenizer_module *)sqlite3Fts3HashFind(pHash, zName, nName+1); if( !p ){ char *zErr2 = sqlite3_mprintf("unknown tokenizer: %s", zName); sqlite3_result_error(context, zErr2, -1); sqlite3_free(zErr2); return; } pRet = Tcl_NewObj(); Tcl_IncrRefCount(pRet); for(i=1; i<argc-1; i++){ azArg[i-1] = (const char *)sqlite3_value_text(argv[i]); } if( SQLITE_OK!=p->xCreate(argc-2, azArg, &pTokenizer) ){ zErr = "error in xCreate()"; goto finish; } pTokenizer->pModule = p; if( sqlite3Fts3OpenTokenizer(pTokenizer, 0, zInput, nInput, &pCsr) ){ zErr = "error in xOpen()"; goto finish; } while( SQLITE_OK==p->xNext(pCsr, &zToken, &nToken, &iStart, &iEnd, &iPos) ){ Tcl_ListObjAppendElement(0, pRet, Tcl_NewIntObj(iPos)); Tcl_ListObjAppendElement(0, pRet, Tcl_NewStringObj(zToken, nToken)); zToken = &zInput[iStart]; nToken = iEnd-iStart; Tcl_ListObjAppendElement(0, pRet, Tcl_NewStringObj(zToken, nToken)); } if( SQLITE_OK!=p->xClose(pCsr) ){ zErr = "error in xClose()"; goto finish; } if( SQLITE_OK!=p->xDestroy(pTokenizer) ){ zErr = "error in xDestroy()"; goto finish; } finish: if( zErr ){ sqlite3_result_error(context, zErr, -1); }else{ sqlite3_result_text(context, Tcl_GetString(pRet), -1, SQLITE_TRANSIENT); } Tcl_DecrRefCount(pRet); }
int text_cmd_plugin(ClientData cd, Tcl_Interp *interp, int argc, const char *argv[]) { VMDApp *app = (VMDApp *)cd; if (!app) return TCL_ERROR; // plugin dlopen <filename> if (argc == 3 && !strupncmp(argv[1], "dlopen", CMDLEN)) { int rc = app->plugin_dlopen(argv[2]); if (rc < 0) { Tcl_AppendResult(interp, "Unable to dlopen plugin file ", argv[2], NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(rc)); return TCL_OK; } // plugin update -- updates list of plugins if (argc == 2 && !strupncmp(argv[1], "update", CMDLEN)) { app->plugin_update(); return TCL_OK; } // plugin list [type]: returns list of category/name pairs. If optional // type is specified, return only plugins of that type. if ((argc == 2 || argc == 3) && !strupncmp(argv[1], "list", CMDLEN)) { const char *type = NULL; if (argc == 3) type = argv[2]; PluginList pluginlist; app->list_plugins(pluginlist, type); const int num = pluginlist.num(); Tcl_Obj *result = Tcl_NewListObj(0, NULL); for (int i=0; i<num; i++) { vmdplugin_t *p = pluginlist[i]; Tcl_Obj *listelem = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, listelem, Tcl_NewStringObj(p->type,-1)); Tcl_ListObjAppendElement(interp, listelem, Tcl_NewStringObj(p->name,-1)); Tcl_ListObjAppendElement(interp, result, listelem); } Tcl_SetObjResult(interp, result); return TCL_OK; } // plugin info <type> <name> <varname> // Puts plugin information for the specified plugin into the array variable // specified by varname. The following array keys will be used: type, // name, author, majorversion, minorversion, reentrant. // returns 1 if plugin information was found, or 0 if no plugin information // is available for that type and name. if (argc == 5 && !strupncmp(argv[1], "info", CMDLEN)) { vmdplugin_t *p = app->get_plugin(argv[2], argv[3]); if (!p) { Tcl_SetResult(interp, (char *) "0", TCL_STATIC); return TCL_OK; } char major[32], minor[32], reentrant[32]; sprintf(major, "%d", p->majorv); sprintf(minor, "%d", p->minorv); sprintf(reentrant, "%d", p->is_reentrant); if (!Tcl_SetVar2(interp,argv[4], "type", p->type, TCL_LEAVE_ERR_MSG) || !Tcl_SetVar2(interp,argv[4], "name", p->name, TCL_LEAVE_ERR_MSG) || !Tcl_SetVar2(interp,argv[4], "author", p->author, TCL_LEAVE_ERR_MSG) || !Tcl_SetVar2(interp,argv[4], "majorversion", major, TCL_LEAVE_ERR_MSG) || !Tcl_SetVar2(interp,argv[4], "minorversion", minor, TCL_LEAVE_ERR_MSG) || !Tcl_SetVar2(interp,argv[4], "reentrant", reentrant, TCL_LEAVE_ERR_MSG)) { Tcl_AppendResult(interp, "Unable to return plugin information in variable ", argv[4], NULL); return TCL_ERROR; } Tcl_SetResult(interp, (char *) "1", TCL_STATIC); return TCL_OK; } Tcl_AppendResult(interp, "Usage: \n\tplugin dlopen <filename> -- Load plugins from a dynamic library\n", "\tplugin update -- Update the list of plugins in the GUI\n", "\tplugin list [<plugin type>] -- List all plugins of the given type\n", "\tplugin info <type> <name> <arrayname> -- Store info about plugin in array\n", NULL); return TCL_ERROR; }
extern "C" void *vmd_mpi_parallel_for_scheduler(void *voidparms) { parallel_for_parms *parfor = (parallel_for_parms *) voidparms; // Run the for loop management code on node zero. // Do the work on all the other nodes... #if defined(VMDTHREADS) int i; wkf_tasktile_t curtile; while (wkf_shared_iterator_next_tile(&parfor->iter, 1, &curtile) != WKF_SCHED_DONE) { i = curtile.start; #else int i; for (i=parfor->loop.start; i<parfor->loop.end; i++) { #endif int reqnode; MPI_Status rcvstat; MPI_Recv(&reqnode, 1, MPI_INT, MPI_ANY_SOURCE, VMD_MPI_TAG_FOR_REQUEST, MPI_COMM_WORLD, &rcvstat); MPI_Send(&i, 1, MPI_INT, reqnode, VMD_MPI_TAG_FOR_REQUEST, MPI_COMM_WORLD); } // tell all nodes we're done with all of the work int node; for (node=1; node<parfor->numnodes; node++) { int reqnode; MPI_Status rcvstat; MPI_Recv(&reqnode, 1, MPI_INT, MPI_ANY_SOURCE, VMD_MPI_TAG_FOR_REQUEST, MPI_COMM_WORLD, &rcvstat); i=-1; // indicate that the for loop is completed MPI_Send(&i, 1, MPI_INT, reqnode, VMD_MPI_TAG_FOR_REQUEST, MPI_COMM_WORLD); } return NULL; } #endif int text_cmd_parallel(ClientData cd, Tcl_Interp *interp, int argc, const char *argv[]) { VMDApp *app = (VMDApp *)cd; if(argc<2) { Tcl_SetResult(interp, (char *) "Parallel job query commands:\n" " parallel nodename\n" " parallel noderank\n" " parallel nodecount\n" "Parallel collective operations (all nodes MUST participate):\n" " parallel allgather <object>\n" " parallel allreduce <tcl reduction proc> <object>\n" " parallel barrier\n" " parallel for <startcount> <endcount> <tcl callback proc> <user data>", TCL_STATIC); return TCL_ERROR; } // XXX hack to make Swift/T cooperate with VMD when using VMD's MPI // communicator if (!strcmp(argv[1], "swift_clone_communicator")) { swift_mpi_init(interp); return TCL_OK; } // return the MPI node name if (!strcmp(argv[1], "nodename")) { Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewStringObj(app->par_name(), strlen(app->par_name()))); Tcl_SetObjResult(interp, tcl_result); return TCL_OK; } // return the MPI node rank if (!strcmp(argv[1], "noderank")) { Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewIntObj(app->par_rank())); Tcl_SetObjResult(interp, tcl_result); return TCL_OK; } // return the MPI node count if (!strcmp(argv[1], "nodecount")) { Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewIntObj(app->par_size())); Tcl_SetObjResult(interp, tcl_result); return TCL_OK; } // execute an MPI barrier if(!strupncmp(argv[1], "barrier", CMDLEN) && argc==2) { app->par_barrier(); return TCL_OK; } // Execute a parallel for loop across all nodes // // parallel for <startcount> <endcount> <callback proc> <user data>", // if(!strupncmp(argv[1], "for", CMDLEN)) { int isok = (argc == 6); int N = app->par_size(); int start, end; if (Tcl_GetInt(interp, argv[2], &start) != TCL_OK || Tcl_GetInt(interp, argv[3], &end) != TCL_OK) { isok = 0; } // // If there's only one node, short-circuit the parallel for // if (N == 1) { if (!isok) { Tcl_SetResult(interp, (char *) "invalid parallel for, missing parameter", TCL_STATIC); return TCL_ERROR; } // run for loop on one node... int i; for (i=start; i<=end; i++) { char istr[128]; sprintf(istr, "%d", i); if (Tcl_VarEval(interp, argv[4], " ", istr, " {", argv[5], "} ", NULL) != TCL_OK) { Tcl_SetResult(interp, (char *) "error occured during parallel for", TCL_STATIC); } } return TCL_OK; } #if defined(VMDMPI) int allok = 0; // Check all node result codes before we continue with the reduction MPI_Allreduce(&isok, &allok, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD); // XXX we may want to verify that all nodes are going to call the same // reduction proc here before continuing further. if (!allok) { Tcl_SetResult(interp, (char *) "invalid parallel for, missing parameter on one or more nodes", TCL_STATIC); return TCL_ERROR; } // Run the for loop management code on node zero. // Do the work on all the other nodes... int i; if (app->par_rank() == 0) { // use multithreaded code path parallel_for_parms parfor; memset(&parfor, 0, sizeof(parfor)); parfor.numnodes = N; parfor.loop.start=start; parfor.loop.end=end+1; wkf_shared_iterator_init(&parfor.iter); wkf_shared_iterator_set(&parfor.iter, &parfor.loop); #if defined(VMDTHREADS) // run the MPI scheduler in a new child thread wkf_thread_t pft; wkf_thread_create(&pft, vmd_mpi_parallel_for_scheduler, &parfor); // run the Tcl in the main thread wkf_tasktile_t curtile; while (wkf_shared_iterator_next_tile(&parfor.iter, 1, &curtile) != WKF_SCHED_DONE) { i = curtile.start; char istr[128]; sprintf(istr, "%d", i); if (Tcl_VarEval(interp, argv[4], " ", istr, " {", argv[5], "} ", NULL) != TCL_OK) { Tcl_SetResult(interp, (char *) "error occured during parallel for", TCL_STATIC); } } // join up with the MPI scheduler thread wkf_thread_join(pft, NULL); #else // if no threads, node zero only runs the scheduler and doesn't do work vmd_mpi_parallel_for_scheduler(&parfor); #endif wkf_shared_iterator_destroy(&parfor.iter); } else { char istr[128]; int done=0; int mynode=app->par_rank(); while (!done) { MPI_Send(&mynode, 1, MPI_INT, 0, VMD_MPI_TAG_FOR_REQUEST, MPI_COMM_WORLD); MPI_Status rcvstat; MPI_Recv(&i, 1, MPI_INT, MPI_ANY_SOURCE, VMD_MPI_TAG_FOR_REQUEST, MPI_COMM_WORLD, &rcvstat); if (i == -1) { done = 1; } else { sprintf(istr, "%d", i); if (Tcl_VarEval(interp, argv[4], " ", istr, " {", argv[5], "} ", NULL) != TCL_OK) { Tcl_SetResult(interp, (char *) "error occured during parallel for", TCL_STATIC); } } } } #endif return TCL_OK; } // Execute an allgather producing a Tcl list of the per-node contributions // // parallel allgather <object> // if(!strupncmp(argv[1], "allgather", CMDLEN)) { int isok = (argc == 3); #if defined(VMDMPI) int allok = 0; int i; // Check all node result codes before we continue with the gather MPI_Allreduce(&isok, &allok, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD); if (!allok) { Tcl_SetResult(interp, (char *) "invalid parallel gather, missing parameter on one or more nodes", TCL_STATIC); return TCL_ERROR; } // Collect parameter size data so we can allocate result buffers // before executing the gather int *szlist = new int[app->par_size()]; szlist[app->par_rank()] = strlen(argv[2])+1; #if defined(USE_MPI_IN_PLACE) // MPI >= 2.x implementations (e.g. NCSA/Cray Blue Waters) MPI_Allgather(MPI_IN_PLACE, 1, MPI_INT, &szlist[0], 1, MPI_INT, MPI_COMM_WORLD); #else // MPI 1.x MPI_Allgather(&szlist[app->par_rank()], 1, MPI_INT, &szlist[0], 1, MPI_INT, MPI_COMM_WORLD); #endif int totalsz = 0; int *displist = new int[app->par_size()]; for (i=0; i<app->par_size(); i++) { displist[i]=totalsz; totalsz+=szlist[i]; } char *recvbuf = new char[totalsz]; memset(recvbuf, 0, totalsz); // Copy this node's data into the correct array position strcpy(&recvbuf[displist[app->par_rank()]], argv[2]); // Perform the parallel gather #if defined(USE_MPI_IN_PLACE) // MPI >= 2.x implementations (e.g. NCSA/Cray Blue Waters) MPI_Allgatherv(MPI_IN_PLACE, szlist[app->par_rank()], MPI_BYTE, &recvbuf[0], szlist, displist, MPI_BYTE, MPI_COMM_WORLD); #else // MPI 1.x MPI_Allgatherv(&recvbuf[displist[app->par_rank()]], szlist[app->par_rank()], MPI_BYTE, &recvbuf[0], szlist, displist, MPI_BYTE, MPI_COMM_WORLD); #endif // Build Tcl result from the array of results Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL); for (i=0; i<app->par_size(); i++) { Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewStringObj(&recvbuf[displist[i]], szlist[i]-1)); } Tcl_SetObjResult(interp, tcl_result); delete [] recvbuf; delete [] displist; delete [] szlist; return TCL_OK; #else if (!isok) { Tcl_SetResult(interp, (char *) "invalid parallel gather, missing parameter on one or more nodes", TCL_STATIC); return TCL_ERROR; } Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewStringObj(argv[2], strlen(argv[2]))); Tcl_SetObjResult(interp, tcl_result); return TCL_OK; #endif } // // Execute an All-Reduce across all of the nodes. // The user must provide a Tcl proc that performs the appropriate reduction // operation for a pair of data items, resulting in a single item. // Since the user may pass floating point data or perform reductions // that give very slightly different answers depending on the order of // operations, the architecture or the host, or whether reductions on // a given host are occuring on the CPU or on a heterogeneous accelerator // or GPU of some kind, we must ensure that all nodes get a bit-identical // result. When heterogeneous accelerators are involved, we can really // only guarantee this by implementing the All-Reduce with a // Reduce-then-Broadcast approach, where the reduction collapses the // result down to node zero, which then does a broadcast to all peers. // // parallel allreduce <tcl reduction proc> <object> // if(!strupncmp(argv[1], "allreduce", CMDLEN)) { int isok = (argc == 4); int N = app->par_size(); // // If there's only one node, short-circuit the full parallel reduction // if (N == 1) { if (!isok) { Tcl_SetResult(interp, (char *) "invalid parallel reduction, missing parameter", TCL_STATIC); return TCL_ERROR; } // return our result, no other reduction is necessary Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], strlen(argv[3]))); return TCL_OK; } #if 1 && defined(VMDMPI) // // All-Reduce implementation based on a ring reduction followed by a // broadcast from node zero. This implementation gaurantees strict // ordering and will properly handle the case where one or more nodes // perform their reduction with slightly differing floating point // rounding than others (e.g. using GPUs, heterogeneous nodes, etc), // and it works with any number of nodes. While NOT latency-optimal, // this implementation is close to bandwidth-optimal which is helpful // for workstation clusters on non-switched networks or networks with // switches that cannot operate in a fully non-blocking manner. // int allok = 0; // Check all node result codes before we continue with the reduction MPI_Allreduce(&isok, &allok, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD); // XXX we may want to verify that all nodes are going to call the same // reduction proc here before continuing further. if (!allok) { Tcl_SetResult(interp, (char *) "invalid parallel reduction, missing parameter on one or more nodes", TCL_STATIC); return TCL_ERROR; } // copy incoming data into initial "result" object Tcl_Obj *resultobj = Tcl_NewStringObj((const char *) argv[3], strlen(argv[3])+1); // A ring-based all-reduce implementation which should be // close to bandwidth-optimal, at the cost of additional latency. int src=app->par_rank(); // src node is this node int Ldest = (N + src + 1) % N; // compute left peer int Rdest = (N + src - 1) % N; // compute right peer MPI_Status status; if (src != 0) { int recvsz = 0; // Post blocking receive for data size MPI_Recv(&recvsz, 1, MPI_INT, Ldest, VMD_MPI_TAG_ALLREDUCE_ARGLENGTH, MPI_COMM_WORLD, &status); // Allocate or resize receive buffer char * recvbuf = (char *) malloc(recvsz); // Post non-blocking receive for data MPI_Recv(recvbuf, recvsz, MPI_BYTE, Ldest, VMD_MPI_TAG_ALLREDUCE_PAYLOAD, MPI_COMM_WORLD, &status); // Perform reduction // Perform the reduction operation on our existing and incoming data. // We build a Tcl command string with the user-defined proc, this // node's previous resultand, and the incoming data, and evaluate it. if (Tcl_VarEval(interp, argv[2], " ", Tcl_GetString(resultobj), " ", recvbuf, NULL) != TCL_OK) { printf("Error occured during reduction!\n"); } // Prep for next reduction step. Set result object to result of // the latest communication/reduction phase. resultobj = Tcl_GetObjResult(interp); // Free the receive buffer free(recvbuf); } // // All nodes // char *sendbuf = Tcl_GetString(resultobj); int sendsz = strlen(sendbuf)+1; // Post blocking send for data size MPI_Send(&sendsz, 1, MPI_INT, Rdest, VMD_MPI_TAG_ALLREDUCE_ARGLENGTH, MPI_COMM_WORLD); // Post blocking send for data MPI_Send(sendbuf, sendsz, MPI_BYTE, Rdest, VMD_MPI_TAG_ALLREDUCE_PAYLOAD, MPI_COMM_WORLD); if (src == 0) { int recvsz = 0; // Post blocking receive for data size MPI_Recv(&recvsz, 1, MPI_INT, Ldest, VMD_MPI_TAG_ALLREDUCE_ARGLENGTH, MPI_COMM_WORLD, &status); // Allocate or resize receive buffer char * recvbuf = (char *) malloc(recvsz); // Post non-blocking receive for data MPI_Recv(recvbuf, recvsz, MPI_BYTE, Ldest, VMD_MPI_TAG_ALLREDUCE_PAYLOAD, MPI_COMM_WORLD, &status); // Perform reduction // Perform the reduction operation on our existing and incoming data. // We build a Tcl command string with the user-defined proc, this // node's previous result and the incoming data, and evaluate it. if (Tcl_VarEval(interp, argv[2], " ", Tcl_GetString(resultobj), " ", recvbuf, NULL) != TCL_OK) { printf("Error occured during reduction!\n"); } // Prep for next reduction step. Set result object to result of // the latest communication/reduction phase. resultobj = Tcl_GetObjResult(interp); // Free the receive buffer free(recvbuf); } // // Broadcast final result from root to peers // if (src == 0) { // update send buffer for root node before broadcast sendbuf = Tcl_GetString(resultobj); sendsz = strlen(sendbuf)+1; MPI_Bcast(&sendsz, 1, MPI_INT, 0, MPI_COMM_WORLD); MPI_Bcast(sendbuf, sendsz, MPI_BYTE, 0, MPI_COMM_WORLD); } else { int recvsz = 0; MPI_Bcast(&recvsz, 1, MPI_INT, 0, MPI_COMM_WORLD); // Allocate or resize receive buffer char * recvbuf = (char *) malloc(recvsz); MPI_Bcast(recvbuf, recvsz, MPI_BYTE, 0, MPI_COMM_WORLD); // Set the final Tcl result if necessary Tcl_SetObjResult(interp, Tcl_NewStringObj(recvbuf, recvsz-1)); // Free the receive buffer free(recvbuf); } return TCL_OK; #elif defined(VMDMPI) // // Power-of-two-only hypercube/butterfly/recursive doubling // All-Reduce implementation. This implementation can't be used // in the case that we have either a non-power-of-two node count or // in the case where we have heterogeneous processing units that may // yield different floating point rounding. For now we leave this // implementation in the code for performance comparisons until we work // out the changes necessary to make it closer to bandwidth-optimal, // heterogeneous-safe, and non-power-of-two capable. // int allok = 0; int i; // Check all node result codes before we continue with the reduction MPI_Allreduce(&isok, &allok, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD); // XXX we may want to verify that all nodes are going to call the same // reduction proc here before continuing further. if (!allok) { Tcl_SetResult(interp, (char *) "invalid parallel reduction, missing parameter on one or more nodes", TCL_STATIC); return TCL_ERROR; } // Calculate number of reduction phases required int log2N; for (log2N=0; N>1; N>>=1) { log2N++; // XXX bail out of we don't have a power-of-two node count, // at least until we implement 3-2 reduction phases if ((N & 1) && (N > 1)) { Tcl_SetResult(interp, (char *) "parallel allreduce only allowed for even power-of-two node count", TCL_STATIC); return TCL_ERROR; } } N = app->par_size(); // copy incoming data into initial "result" object Tcl_Obj *resultobj = Tcl_NewStringObj((const char *) argv[3], strlen(argv[3])+1); // An all-reduce tree with hypercube connectivity with // log2(N) communication/reduction phases. At each phase, we compute // the peer/destination node we will communicate with using an XOR of // our node ID with the current hypercube dimension. If we have an // incomplete hypercube topology (e.g. non-power-of-two node count), // we have to do special 3-2 communication rounds (not implemented yet). // The current implementation requires that all existing nodes // participate, and that they contribute a valid data item. // If we wish to support reductions where a node may not contribute, // we would need to handle that similarly to a peer node that doesn't // exist, but we would likely determine this during the parameter length // exchange step. int src=app->par_rank(); // src node is this node for (i=0; i<log2N; i++) { int mask = 1 << i; // generate bitmask to use in the XOR int dest = src ^ mask; // XOR src node with bitmask to find dest node Tcl_Obj *oldresultobj = resultobj; // track old result // Check to make sure dest node exists for non-power-of-two // node counts (an incomplete hypercube). If not, skip to the next // communication/reduction phase. if (dest < N) { char *sendbuf = Tcl_GetString(oldresultobj); int sendsz = strlen(sendbuf)+1; int recvsz = 0; MPI_Request handle; MPI_Status status; // // Exchange required receive buffer size for data exchange with peer // // Post non-blocking receive for data size MPI_Irecv(&recvsz, 1, MPI_INT, dest, VMD_MPI_TAG_ALLREDUCE_ARGLENGTH, MPI_COMM_WORLD, &handle); // Post blocking send for data size MPI_Send(&sendsz, 1, MPI_INT, dest, VMD_MPI_TAG_ALLREDUCE_ARGLENGTH, MPI_COMM_WORLD); // Wait for non-blocking receive of data size to complete MPI_Wait(&handle, &status); // printf("src[%d], dest[%d], value '%s', recvsz: %d\n", src, dest, sendbuf, recvsz); // Allocate or resize receive buffer char * recvbuf = (char *) malloc(recvsz); // // Exchange the data payload // // Post non-blocking receive for data MPI_Irecv(recvbuf, recvsz, MPI_BYTE, dest, VMD_MPI_TAG_ALLREDUCE_PAYLOAD, MPI_COMM_WORLD, &handle); // Post blocking send for data MPI_Send(sendbuf, sendsz, MPI_BYTE, dest, VMD_MPI_TAG_ALLREDUCE_PAYLOAD, MPI_COMM_WORLD); // Wait for receive of data MPI_Wait(&handle, &status); // Perform the reduction operation on our existing and incoming data. // We build a Tcl command string with the user-defined proc, this // node's previous result and the incoming data, and evaluate it. if (Tcl_VarEval(interp, argv[2], " ", sendbuf, " ", recvbuf, NULL) != TCL_OK) { printf("Error occured during reduction!\n"); } // Free the receive buffer free(recvbuf); // Prep for next reduction step. Set result object to result of // the latest communication/reduction phase. resultobj = Tcl_GetObjResult(interp); } } // Set the final Tcl result if necessary Tcl_SetObjResult(interp, resultobj); return TCL_OK; #endif }
void Tcl_MainEx( int argc, /* Number of arguments. */ TCHAR **argv, /* Array of argument strings. */ Tcl_AppInitProc *appInitProc, /* Application-specific initialization * function to call after most initialization * but before starting to execute commands. */ Tcl_Interp *interp) { Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; int code, exitCode = 0; Tcl_MainLoopProc *mainLoopProc; Tcl_Channel chan; InteractiveState is; TclpSetInitialEncodings(); TclpFindExecutable((const char *)argv[0]); Tcl_InitMemory(interp); is.interp = interp; is.prompt = PROMPT_START; is.commandPtr = Tcl_NewObj(); /* * 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 == _tcscmp(TEXT("-encoding"), argv[1])) && ('-' != argv[3][0])) { Tcl_Obj *value = NewNativeObj(argv[2], -1); Tcl_SetStartupScript(NewNativeObj(argv[3], -1), Tcl_GetString(value)); Tcl_DecrRefCount(value); argc -= 3; argv += 3; } else if ((argc > 1) && ('-' != argv[1][0])) { Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL); argc--; argv++; } } path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { appName = NewNativeObj(argv[0], -1); } else { appName = path; } Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); argc--; argv++; Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1)); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. */ is.tty = isatty(0); Tcl_SetVar2Ex(interp, "tcl_interactive", NULL, Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. */ Tcl_Preserve(interp); if (appInitProc(interp) != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_WriteChars(chan, "application-specific initialization failed: ", -1); Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } } if (Tcl_InterpDeleted(interp)) { goto done; } if (Tcl_LimitExceeded(interp)) { goto done; } if (TclFullFinalizationRequested()) { /* * Arrange for final deletion of the main interp */ /* ARGH Munchhausen effect */ Tcl_CreateExitHandler(FreeMainInterp, interp); } /* * Invoke the script specified on the command line, if any. Must fetch it * again, as the appInitProc might have reset it. */ path = Tcl_GetStartupScript(&encodingName); if (path != NULL) { Tcl_ResetResult(interp); code = Tcl_FSEvalFileEx(interp, path, encodingName); if (code != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { 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(chan, valuePtr); } Tcl_WriteChars(chan, "\n", 1); Tcl_DecrRefCount(options); } 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. */ Tcl_IncrRefCount(is.commandPtr); /* * Get a new value for tty if anyone writes to ::tcl_interactive */ Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN); is.input = Tcl_GetStdChannel(TCL_STDIN); while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) { mainLoopProc = TclGetMainLoop(); if (mainLoopProc == NULL) { int length; if (is.tty) { Prompt(interp, &is); if (Tcl_InterpDeleted(interp)) { break; } if (Tcl_LimitExceeded(interp)) { break; } is.input = Tcl_GetStdChannel(TCL_STDIN); if (is.input == NULL) { break; } } if (Tcl_IsShared(is.commandPtr)) { Tcl_DecrRefCount(is.commandPtr); is.commandPtr = Tcl_DuplicateObj(is.commandPtr); Tcl_IncrRefCount(is.commandPtr); } length = Tcl_GetsObj(is.input, is.commandPtr); if (length < 0) { if (Tcl_InputBlocked(is.input)) { /* * 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(is.commandPtr)) { Tcl_DecrRefCount(is.commandPtr); is.commandPtr = Tcl_DuplicateObj(is.commandPtr); Tcl_IncrRefCount(is.commandPtr); } Tcl_AppendToObj(is.commandPtr, "\n", 1); if (!TclObjCommandComplete(is.commandPtr)) { is.prompt = PROMPT_CONTINUE; continue; } is.prompt = PROMPT_START; /* * The final newline is syntactically redundant, and causes some * error messages troubles deeper in, so lop it back off. */ Tcl_GetStringFromObj(is.commandPtr, &length); Tcl_SetObjLength(is.commandPtr, --length); code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL); is.input = Tcl_GetStdChannel(TCL_STDIN); Tcl_DecrRefCount(is.commandPtr); is.commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(is.commandPtr); if (code != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } } else if (is.tty) { resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); Tcl_GetStringFromObj(resultPtr, &length); chan = Tcl_GetStdChannel(TCL_STDOUT); if ((length > 0) && chan) { Tcl_WriteObj(chan, resultPtr); Tcl_WriteChars(chan, "\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. */ if (is.input) { if (is.tty) { Prompt(interp, &is); } Tcl_CreateChannelHandler(is.input, TCL_READABLE, StdinProc, &is); } mainLoopProc(); Tcl_SetMainLoop(NULL); if (is.input) { Tcl_DeleteChannelHandler(is.input, StdinProc, &is); } is.input = Tcl_GetStdChannel(TCL_STDIN); } /* * This code here only for the (unsupported and deprecated) [checkmem] * command. */ #ifdef TCL_MEM_DEBUG if (tclMemDumpFileName != NULL) { Tcl_SetMainLoop(NULL); Tcl_DeleteInterp(interp); } #endif /* TCL_MEM_DEBUG */ } done: mainLoopProc = TclGetMainLoop(); if ((exitCode == 0) && mainLoopProc && !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(); Tcl_SetMainLoop(NULL); } if (is.commandPtr != NULL) { Tcl_DecrRefCount(is.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) && !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. */ Tcl_Exit(exitCode); }