Exemplo n.º 1
0
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;
}
Exemplo n.º 2
0
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;
}
Exemplo n.º 3
0
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;
}
Exemplo n.º 4
0
/* $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;
}
Exemplo n.º 5
0
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;
}
Exemplo n.º 6
0
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;
}
Exemplo n.º 7
0
/*-----------------------------------------------------------------------------
 * 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;
}
Exemplo n.º 8
0
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;
}
Exemplo n.º 9
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;
}
Exemplo n.º 10
0
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;
}
Exemplo n.º 11
0
Arquivo: tcltk.c Projeto: kmillar/rho
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);
}
Exemplo n.º 12
0
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;
}
Exemplo n.º 13
0
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;
}
Exemplo n.º 14
0
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;
}
Exemplo n.º 15
0
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;
    }
}
Exemplo n.º 16
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);
}
Exemplo n.º 17
0
static int tclvarFilter(
  sqlite3_vtab_cursor *pVtabCursor, 
  int idxNum, const char *idxStr,
  int argc, sqlite3_value **argv
){
  tclvar_cursor *pCur = (tclvar_cursor *)pVtabCursor;
  Tcl_Interp *interp = ((tclvar_vtab *)(pVtabCursor->pVtab))->interp;

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

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

  Tcl_DecrRefCount(p);
  return tclvarNext(pVtabCursor);
}
Exemplo n.º 18
0
/*
  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;
}
Exemplo n.º 19
0
	/* 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;
}
Exemplo n.º 20
0
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;
}
Exemplo n.º 21
0
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;
}
Exemplo n.º 22
0
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;
}
Exemplo n.º 23
0
Arquivo: tkWinSend.c Projeto: dgsb/tk
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 */
}
Exemplo n.º 24
0
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);
}
Exemplo n.º 26
0
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;
}
Exemplo n.º 27
0
/*
** 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);
}
Exemplo n.º 28
0
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;
}
Exemplo n.º 29
0
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
  }
Exemplo n.º 30
0
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);
}