예제 #1
0
static void
ConsoleInit(void)
{
    ThreadSpecificData *tsdPtr;

    /*
     * Check the initialized flag first, then check again in the mutex. This
     * is a speed enhancement.
     */

    if (!initialized) {
	Tcl_MutexLock(&consoleMutex);
	if (!initialized) {
	    initialized = 1;
	    Tcl_CreateExitHandler(ProcExitHandler, NULL);
	}
	Tcl_MutexUnlock(&consoleMutex);
    }

    tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
    if (tsdPtr == NULL) {
	tsdPtr = TCL_TSD_INIT(&dataKey);
	tsdPtr->firstConsolePtr = NULL;
	Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
	Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL);
    }
}
예제 #2
0
ObjToRepMap::ObjToRepMap ()
{
    Tcl_InitHashTable(&m_objMap, TCL_ONE_WORD_KEYS);

#ifdef TCL_THREADS
    Tcl_CreateThreadExitHandler(exitProc, this);
#else
    Tcl_CreateExitHandler(exitProc, 0);
#endif
}
예제 #3
0
파일: tclThreadTest.c 프로젝트: aosm/tcl
static int
ThreadEventProc(
    Tcl_Event *evPtr,		/* Really ThreadEvent */
    int mask)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr;
    ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
    Tcl_Interp *interp = tsdPtr->interp;
    int code;
    const char *result, *errorCode, *errorInfo;

    if (interp == NULL) {
	code = TCL_ERROR;
	result = "no target interp!";
	errorCode = "THREAD";
	errorInfo = "";
    } else {
	Tcl_Preserve((ClientData) interp);
	Tcl_ResetResult(interp);
	Tcl_CreateThreadExitHandler(ThreadFreeProc,
		(ClientData) threadEventPtr->script);
	code = Tcl_GlobalEval(interp, threadEventPtr->script);
	Tcl_DeleteThreadExitHandler(ThreadFreeProc,
		(ClientData) threadEventPtr->script);
	if (code != TCL_OK) {
	    errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
	    errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
	} else {
	    errorCode = errorInfo = NULL;
	}
	result = Tcl_GetStringResult(interp);
    }
    ckfree(threadEventPtr->script);
    if (resultPtr) {
	Tcl_MutexLock(&threadMutex);
	resultPtr->code = code;
	resultPtr->result = ckalloc(strlen(result) + 1);
	strcpy(resultPtr->result, result);
	if (errorCode != NULL) {
	    resultPtr->errorCode = ckalloc(strlen(errorCode) + 1);
	    strcpy(resultPtr->errorCode, errorCode);
	}
	if (errorInfo != NULL) {
	    resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);
	    strcpy(resultPtr->errorInfo, errorInfo);
	}
	Tcl_ConditionNotify(&resultPtr->done);
	Tcl_MutexUnlock(&threadMutex);
    }
    if (interp != NULL) {
	Tcl_Release((ClientData) interp);
    }
    return 1;
}
예제 #4
0
파일: tclTimer.c 프로젝트: smh377/tcl
static ThreadSpecificData *
InitTimer(void)
{
    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);

    if (tsdPtr == NULL) {
	tsdPtr = TCL_TSD_INIT(&dataKey);
	Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL);
	Tcl_CreateThreadExitHandler(TimerExitProc, NULL);
    }
    return tsdPtr;
}
예제 #5
0
파일: tkOption.c 프로젝트: das/tcltk
static void
OptionInit(
    register TkMainInfo *mainPtr)
				/* Top-level information about window that
				 * isn't initialized yet. */
{
    int i;
    Tcl_Interp *interp;
    ThreadSpecificData *tsdPtr =
	    Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
    Element *defaultMatchPtr = &tsdPtr->defaultMatch;

    /*
     * First, once-only initialization.
     */

    if (tsdPtr->initialized == 0) {
	tsdPtr->initialized = 1;
	tsdPtr->cachedWindow = NULL;
	tsdPtr->numLevels = 5;
	tsdPtr->curLevel = -1;
	tsdPtr->serial = 0;

	tsdPtr->levels = (StackLevel *)
		ckalloc((unsigned) (5*sizeof(StackLevel)));
	for (i = 0; i < NUM_STACKS; i++) {
	    tsdPtr->stacks[i] = NewArray(10);
	    tsdPtr->levels[0].bases[i] = 0;
	}

	defaultMatchPtr->nameUid = NULL;
	defaultMatchPtr->child.valueUid = NULL;
	defaultMatchPtr->priority = -1;
	defaultMatchPtr->flags = 0;
	Tcl_CreateThreadExitHandler(OptionThreadExitProc, NULL);
    }

    /*
     * Then, per-main-window initialization. Create and delete dummy
     * interpreter for message logging.
     */

    mainPtr->optionRootPtr = NewArray(20);
    interp = Tcl_CreateInterp();
    GetDefaultOptions(interp, mainPtr->winPtr);
    Tcl_DeleteInterp(interp);
}
예제 #6
0
파일: tkGet.c 프로젝트: das/tk
Tk_Uid
Tk_GetUid(
    const char *string)		/* String to convert. */
{
    int dummy;
    ThreadSpecificData *tsdPtr =
        Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
    Tcl_HashTable *tablePtr = &tsdPtr->uidTable;

    if (!tsdPtr->initialized) {
        Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
        Tcl_CreateThreadExitHandler(FreeUidThreadExitProc, NULL);
        tsdPtr->initialized = 1;
    }
    return (Tk_Uid) Tcl_GetHashKey(tablePtr,
                                   Tcl_CreateHashEntry(tablePtr, string, &dummy));
}
void
Tk_CreateImageType(
    Tk_ImageType *typePtr)	/* Structure describing the type. All of the
				 * fields except "nextPtr" must be filled in
				 * by caller. */
{
	Tk_ImageType *copyPtr;
    ThreadSpecificData *tsdPtr =
	    Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));

    if (!tsdPtr->initialized) {
	tsdPtr->initialized = 1;
	Tcl_CreateThreadExitHandler(ImageTypeThreadExitProc, NULL);
    }
    copyPtr = (Tk_ImageType *) ckalloc(sizeof(Tk_ImageType));
    *copyPtr = *typePtr;
    copyPtr->nextPtr = tsdPtr->imageTypeList;
    tsdPtr->imageTypeList = copyPtr;
}
예제 #8
0
파일: variables.cpp 프로젝트: mdmitr/surfit
void surfit_init_all() {

	functionals = new std::vector<functional *>;

	randomize();
	reproject_faults = 1;
	reproject_undef_areas = 0;
	process_isolated_areas = 1;
	tol = float(1e-5);
	undef_value = FLT_MAX;
	write_mat = false;

	sor_omega = REAL(1.6);
	ssor_omega = REAL(1.6);

	surfit_data_manager = new data_manager;
	add_manager(new surfit_manager);

	Tcl_CreateThreadExitHandler(data_cleanup, NULL);
#ifdef HAVE_THREADS
#ifdef WIN32
	SYSTEM_INFO info;
	GetSystemInfo(&info);
	size_t cpu = info.dwNumberOfProcessors;
#else
#ifdef _SC_NPROCESSORS_ONLN
	cpu = sysconf(_SC_NPROCESSORS_ONLN);
#else
	cpu = 1;
#endif
	if (cpu < 1)
		cpu = 1;
#endif
	sstuff_init_threads(cpu);
#endif

};
예제 #9
0
파일: tkConsole.c 프로젝트: lmiadowicz/tk
int
Tk_CreateConsoleWindow(
    Tcl_Interp *interp)		/* Interpreter to use for prompting. */
{
    Tcl_Channel chan;
    ConsoleInfo *info;
    Tk_Window mainWindow;
    Tcl_Command token;
    int result = TCL_OK;
    int haveConsoleChannel = 1;

    /* Init an interp with Tcl and Tk */
    Tcl_Interp *consoleInterp = Tcl_CreateInterp();
    if (Tcl_Init(consoleInterp) != TCL_OK) {
	goto error;
    }
    if (Tk_Init(consoleInterp) != TCL_OK) {
	goto error;
    }

    /*
     * Fetch the instance data from whatever std channel is a
     * console channel.  If none, create fresh instance data.
     */

    if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN))
	    == &consoleChannelType) {
    } else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT))
	    == &consoleChannelType) {
    } else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR))
	    == &consoleChannelType) {
    } else {
	haveConsoleChannel = 0;
    }

    if (haveConsoleChannel) {
	ChannelData *data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
	info = data->info;
	if (info->consoleInterp) {
	    /* New ConsoleInfo for a new console window */
	    info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
	    info->refCount = 0;

	    /* Update any console channels to make use of the new console */
	    if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN))
		    == &consoleChannelType) {
		data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
		data->info->refCount--;
		data->info = info;
		data->info->refCount++;
	    }
	    if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT))
		    == &consoleChannelType) {
		data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
		data->info->refCount--;
		data->info = info;
		data->info->refCount++;
	    }
	    if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR))
		    == &consoleChannelType) {
		data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
		data->info->refCount--;
		data->info = info;
		data->info->refCount++;
	    }
	}
    } else {
	info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
	info->refCount = 0;
    }

    info->consoleInterp = consoleInterp;
    info->interp = interp;

    Tcl_CallWhenDeleted(consoleInterp, InterpDeleteProc, info);
    info->refCount++;
    Tcl_CreateThreadExitHandler(DeleteConsoleInterp, consoleInterp);

    /*
     * Add console commands to the interp
     */

    token = Tcl_CreateObjCommand(interp, "console", ConsoleObjCmd, info,
	    ConsoleDeleteProc);
    info->refCount++;

    /*
     * We don't have to count the ref held by the [consoleinterp] command
     * in the consoleInterp.  The ref held by the consoleInterp delete
     * handler takes care of us.
     */
    Tcl_CreateObjCommand(consoleInterp, "consoleinterp", InterpreterObjCmd,
	    info, NULL);

    mainWindow = Tk_MainWindow(interp);
    if (mainWindow) {
	Tk_CreateEventHandler(mainWindow, StructureNotifyMask,
		ConsoleEventProc, info);
	info->refCount++;
    }

    Tcl_Preserve(consoleInterp);
    result = Tcl_GlobalEval(consoleInterp, "source $tk_library/console.tcl");
    if (result == TCL_ERROR) {
	Tcl_SetReturnOptions(interp,
		Tcl_GetReturnOptions(consoleInterp, result));
	Tcl_SetObjResult(interp, Tcl_GetObjResult(consoleInterp));
    }
    Tcl_Release(consoleInterp);
    if (result == TCL_ERROR) {
	Tcl_DeleteCommandFromToken(interp, token);
	mainWindow = Tk_MainWindow(interp);
	if (mainWindow) {
	    Tk_DeleteEventHandler(mainWindow, StructureNotifyMask,
		    ConsoleEventProc, info);
	    if (--info->refCount <= 0) {
		ckfree((char *) info);
	    }
	}
	goto error;
    }
    return TCL_OK;

  error:
    Tcl_AddErrorInfo(interp, "\n    (creating console window)");
    if (!Tcl_InterpDeleted(consoleInterp)) {
	Tcl_DeleteInterp(consoleInterp);
    }
    return TCL_ERROR;
}
예제 #10
0
파일: tclWinThrd.c 프로젝트: smh377/tcl
void
Tcl_ConditionWait(
    Tcl_Condition *condPtr,	/* Really (WinCondition **) */
    Tcl_Mutex *mutexPtr,	/* Really (CRITICAL_SECTION **) */
    const Tcl_Time *timePtr) /* Timeout on waiting period */
{
    WinCondition *winCondPtr;	/* Per-condition queue head */
    CRITICAL_SECTION *csPtr;	/* Caller's Mutex, after casting */
    DWORD wtime;		/* Windows time value */
    int timeout;		/* True if we got a timeout */
    int doExit = 0;		/* True if we need to do exit setup */
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * Self initialize the two parts of the condition. The per-condition and
     * per-thread parts need to be handled independently.
     */

    if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	TclpMasterLock();

	/*
	 * Create the per-thread event and queue pointers.
	 */

	if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	    tsdPtr->condEvent = CreateEvent(NULL, TRUE /* manual reset */,
		    FALSE /* non signaled */, NULL);
	    tsdPtr->nextPtr = NULL;
	    tsdPtr->prevPtr = NULL;
	    tsdPtr->flags = WIN_THREAD_RUNNING;
	    doExit = 1;
	}
	TclpMasterUnlock();

	if (doExit) {
	    /*
	     * Create a per-thread exit handler to clean up the condEvent. We
	     * must be careful to do this outside the Master Lock because
	     * Tcl_CreateThreadExitHandler uses its own ThreadSpecificData,
	     * and initializing that may drop back into the Master Lock.
	     */

	    Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr);
	}
    }

    if (*condPtr == NULL) {
	TclpMasterLock();

	/*
	 * Initialize the per-condition queue pointers and Mutex.
	 */

	if (*condPtr == NULL) {
	    winCondPtr = ckalloc(sizeof(WinCondition));
	    InitializeCriticalSection(&winCondPtr->condLock);
	    winCondPtr->firstPtr = NULL;
	    winCondPtr->lastPtr = NULL;
	    *condPtr = (Tcl_Condition) winCondPtr;
	    TclRememberCondition(condPtr);
	}
	TclpMasterUnlock();
    }
    csPtr = *((CRITICAL_SECTION **)mutexPtr);
    winCondPtr = *((WinCondition **)condPtr);
    if (timePtr == NULL) {
	wtime = INFINITE;
    } else {
	wtime = timePtr->sec * 1000 + timePtr->usec / 1000;
    }

    /*
     * Queue the thread on the condition, using the per-condition lock for
     * serialization.
     */

    tsdPtr->flags = WIN_THREAD_BLOCKED;
    tsdPtr->nextPtr = NULL;
    EnterCriticalSection(&winCondPtr->condLock);
    tsdPtr->prevPtr = winCondPtr->lastPtr;		/* A: */
    winCondPtr->lastPtr = tsdPtr;
    if (tsdPtr->prevPtr != NULL) {
	tsdPtr->prevPtr->nextPtr = tsdPtr;
    }
    if (winCondPtr->firstPtr == NULL) {
	winCondPtr->firstPtr = tsdPtr;
    }

    /*
     * Unlock the caller's mutex and wait for the condition, or a timeout.
     * There is a minor issue here in that we don't count down the timeout if
     * we get notified, but another thread grabs the condition before we do.
     * In that race condition we'll wait again for the full timeout. Timed
     * waits are dubious anyway. Either you have the locking protocol wrong
     * and are masking a deadlock, or you are using conditions to pause your
     * thread.
     */

    LeaveCriticalSection(csPtr);
    timeout = 0;
    while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) {
	ResetEvent(tsdPtr->condEvent);
	LeaveCriticalSection(&winCondPtr->condLock);
	if (WaitForSingleObjectEx(tsdPtr->condEvent, wtime,
		TRUE) == WAIT_TIMEOUT) {
	    timeout = 1;
	}
	EnterCriticalSection(&winCondPtr->condLock);
    }

    /*
     * Be careful on timeouts because the signal might arrive right around the
     * time limit and someone else could have taken us off the queue.
     */

    if (timeout) {
	if (tsdPtr->flags & WIN_THREAD_RUNNING) {
	    timeout = 0;
	} else {
	    /*
	     * When dequeuing, we can leave the tsdPtr->nextPtr and
	     * tsdPtr->prevPtr with dangling pointers because they are
	     * reinitialilzed w/out reading them when the thread is enqueued
	     * later.
	     */

	    if (winCondPtr->firstPtr == tsdPtr) {
		winCondPtr->firstPtr = tsdPtr->nextPtr;
	    } else {
		tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
	    }
	    if (winCondPtr->lastPtr == tsdPtr) {
		winCondPtr->lastPtr = tsdPtr->prevPtr;
	    } else {
		tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
	    }
	    tsdPtr->flags = WIN_THREAD_RUNNING;
	}
    }

    LeaveCriticalSection(&winCondPtr->condLock);
    EnterCriticalSection(csPtr);
}
	/* ARGSUSED */
int
Tcl_PutsObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to puts on. */
    Tcl_Obj *string;		/* String to write. */
    Tcl_Obj *chanObjPtr = NULL;	/* channel object. */
    int newline;		/* Add a newline at end? */
    int result;			/* Result of puts operation. */
    int mode;			/* Mode in which channel is opened. */
    ThreadSpecificData *tsdPtr;

    switch (objc) {
    case 2: /* [puts $x] */
	string = objv[1];
	newline = 1;
	break;

    case 3: /* [puts -nonewline $x] or [puts $chan $x] */
	if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
	    newline = 0;
	} else {
	    newline = 1;
	    chanObjPtr = objv[1];
	}
	string = objv[2];
	break;

    case 4: /* [puts -nonewline $chan $x] or [puts $chan $x nonewline] */
	if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
	    chanObjPtr = objv[2];
	    string = objv[3];
	} else {
	    /*
	     * The code below provides backwards compatibility with an old
	     * form of the command that is no longer recommended or
	     * documented.
	     */

	    char *arg;
	    int length;

	    arg = TclGetStringFromObj(objv[3], &length);
	    if ((length != 9)
		    || (strncmp(arg, "nonewline", (size_t) length) != 0)) {
		Tcl_AppendResult(interp, "bad argument \"", arg,
			"\": should be \"nonewline\"", NULL);
		return TCL_ERROR;
	    }
	    chanObjPtr = objv[1];
	    string = objv[2];
	}
	newline = 0;
	break;

    default:
	/* [puts] or [puts some bad number of arguments...] */
	Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
	return TCL_ERROR;
    }

    if (chanObjPtr == NULL) {
	tsdPtr = TCL_TSD_INIT(&dataKey);

	if (!tsdPtr->initialized) {
	    tsdPtr->initialized = 1;
	    TclNewLiteralStringObj(tsdPtr->stdoutObjPtr, "stdout");
	    Tcl_IncrRefCount(tsdPtr->stdoutObjPtr);
	    Tcl_CreateThreadExitHandler(FinalizeIOCmdTSD, NULL);
	}
	chanObjPtr = tsdPtr->stdoutObjPtr;
    }
    if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
	return TCL_ERROR;
    }
    if ((mode & TCL_WRITABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr),
		"\" wasn't opened for writing", NULL);
	return TCL_ERROR;
    }

    result = Tcl_WriteObj(chan, string);
    if (result < 0) {
	goto error;
    }
    if (newline != 0) {
	result = Tcl_WriteChars(chan, "\n", 1);
	if (result < 0) {
	    goto error;
	}
    }
    return TCL_OK;

    /*
     * TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result. Fall back to the regular
     * message if nothing was found in the bypass.
     */

  error:
    if (!TclChanCaughtErrorBypass(interp, chan)) {
	Tcl_AppendResult(interp, "error writing \"",
		TclGetString(chanObjPtr), "\": ",
		Tcl_PosixError(interp), NULL);
    }
    return TCL_ERROR;
}
예제 #12
0
파일: tclThreadTest.c 프로젝트: aosm/tcl
Tcl_ThreadCreateType
NewTestThread(
    ClientData clientData)
{
    ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    int result;
    char *threadEvalScript;

    /*
     * Initialize the interpreter.  This should be more general.
     */

    tsdPtr->interp = Tcl_CreateInterp();
    result = Tcl_Init(tsdPtr->interp);
    result = TclThread_Init(tsdPtr->interp);

    /*
     * This is part of the test facility. Initialize _ALL_ test commands for
     * use by the new thread.
     */

    result = Tcltest_Init(tsdPtr->interp);

    /*
     * Update the list of threads.
     */

    Tcl_MutexLock(&threadMutex);
    ListUpdateInner(tsdPtr);

    /*
     * We need to keep a pointer to the alloc'ed mem of the script we are
     * eval'ing, for the case that we exit during evaluation
     */

    threadEvalScript = ckalloc(strlen(ctrlPtr->script)+1);
    strcpy(threadEvalScript, ctrlPtr->script);

    Tcl_CreateThreadExitHandler(ThreadExitProc, (ClientData) threadEvalScript);

    /*
     * Notify the parent we are alive.
     */

    Tcl_ConditionNotify(&ctrlPtr->condWait);
    Tcl_MutexUnlock(&threadMutex);

    /*
     * Run the script.
     */

    Tcl_Preserve((ClientData) tsdPtr->interp);
    result = Tcl_Eval(tsdPtr->interp, threadEvalScript);
    if (result != TCL_OK) {
	ThreadErrorProc(tsdPtr->interp);
    }

    /*
     * Clean up.
     */

    ListRemove(tsdPtr);
    Tcl_Release((ClientData) tsdPtr->interp);
    Tcl_DeleteInterp(tsdPtr->interp);
    Tcl_ExitThread(result);

    TCL_THREAD_CREATE_RETURN;
}
예제 #13
0
파일: tclThreadTest.c 프로젝트: aosm/tcl
	/* ARGSUSED */
int
Tcl_ThreadObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    int option;
    static const char *threadOptions[] = {
	"create", "exit", "id", "join", "names",
	"send", "wait", "errorproc", NULL
    };
    enum options {
	THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN, THREAD_NAMES,
	THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions, "option", 0,
	    &option) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Make sure the initial thread is on the list before doing anything.
     */

    if (tsdPtr->interp == NULL) {
	Tcl_MutexLock(&threadMutex);
	tsdPtr->interp = interp;
	ListUpdateInner(tsdPtr);
	Tcl_CreateThreadExitHandler(ThreadExitProc, NULL);
	Tcl_MutexUnlock(&threadMutex);
    }

    switch ((enum options)option) {
    case THREAD_CREATE: {
	char *script;
	int joinable, len;

	if (objc == 2) {
	    /*
	     * Neither joinable nor special script
	     */

	    joinable = 0;
	    script = "testthread wait";		/* Just enter event loop */
	} else if (objc == 3) {
	    /*
	     * Possibly -joinable, then no special script, no joinable, then
	     * its a script.
	     */

	    script = Tcl_GetStringFromObj(objv[2], &len);

	    if ((len > 1) &&
		    (script [0] == '-') && (script [1] == 'j') &&
		    (0 == strncmp (script, "-joinable", (size_t) len))) {
		joinable = 1;
		script = "testthread wait";	/* Just enter event loop */
	    } else {
		/*
		 * Remember the script
		 */

		joinable = 0;
	    }
	} else if (objc == 4) {
	    /*
	     * Definitely a script available, but is the flag -joinable?
	     */

	    script = Tcl_GetStringFromObj(objv[2], &len);

	    joinable = ((len > 1) &&
		    (script [0] == '-') && (script [1] == 'j') &&
		    (0 == strncmp(script, "-joinable", (size_t) len)));

	    script = Tcl_GetString(objv[3]);
	} else {
	    Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
	    return TCL_ERROR;
	}
	return TclCreateThread(interp, script, joinable);
    }
    case THREAD_EXIT:
	if (objc > 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	ListRemove(NULL);
	Tcl_ExitThread(0);
	return TCL_OK;
    case THREAD_ID:
	if (objc == 2) {
	    Tcl_Obj *idObj = Tcl_NewLongObj((long) Tcl_GetCurrentThread());

	    Tcl_SetObjResult(interp, idObj);
	    return TCL_OK;
	} else {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
    case THREAD_JOIN: {
	long id;
	int result, status;

	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "id");
	    return TCL_ERROR;
	}
	if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) {
	    return TCL_ERROR;
	}

	result = Tcl_JoinThread ((Tcl_ThreadId) id, &status);
	if (result == TCL_OK) {
	    Tcl_SetIntObj (Tcl_GetObjResult (interp), status);
	} else {
	    char buf [20];

	    sprintf(buf, "%ld", id);
	    Tcl_AppendResult(interp, "cannot join thread ", buf, NULL);
	}
	return result;
    }
    case THREAD_NAMES:
	if (objc > 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	return TclThreadList(interp);
    case THREAD_SEND: {
	long id;
	char *script;
	int wait, arg;

	if ((objc != 4) && (objc != 5)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
	    return TCL_ERROR;
	}
	if (objc == 5) {
	    if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {
		Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
		return TCL_ERROR;
	    }
	    wait = 0;
	    arg = 3;
	} else {
	    wait = 1;
	    arg = 2;
	}
	if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {
	    return TCL_ERROR;
	}
	arg++;
	script = Tcl_GetString(objv[arg]);
	return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait);
    }
    case THREAD_ERRORPROC: {
	/*
	 * Arrange for this proc to handle thread death errors.
	 */

	char *proc;

	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "proc");
	    return TCL_ERROR;
	}
	Tcl_MutexLock(&threadMutex);
	errorThreadId = Tcl_GetCurrentThread();
	if (errorProcString) {
	    ckfree(errorProcString);
	}
	proc = Tcl_GetString(objv[2]);
	errorProcString = ckalloc(strlen(proc)+1);
	strcpy(errorProcString, proc);
	Tcl_MutexUnlock(&threadMutex);
	return TCL_OK;
    }
    case THREAD_WAIT:
	while (1) {
	    (void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
	}
    }
    return TCL_OK;
}
예제 #14
0
파일: tclRegexp.c 프로젝트: afmayer/tcl-tk
static TclRegexp *
CompileRegexp(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    const char *string,		/* The regexp to compile (UTF-8). */
    int length,			/* The length of the string in bytes. */
    int flags)			/* Compilation flags. */
{
    TclRegexp *regexpPtr;
    const Tcl_UniChar *uniString;
    int numChars, status, i, exact;
    Tcl_DString stringBuf;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!tsdPtr->initialized) {
	tsdPtr->initialized = 1;
	Tcl_CreateThreadExitHandler(FinalizeRegexp, NULL);
    }

    /*
     * This routine maintains a second-level regular expression cache in
     * addition to the per-object regexp cache. The per-thread cache is needed
     * to handle the case where for various reasons the object is lost between
     * invocations of the regexp command, but the literal pattern is the same.
     */

    /*
     * Check the per-thread compiled regexp cache. We can only reuse a regexp
     * if it has the same pattern and the same flags.
     */

    for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
	if ((length == tsdPtr->patLengths[i])
		&& (tsdPtr->regexps[i]->flags == flags)
		&& (strcmp(string, tsdPtr->patterns[i]) == 0)) {
	    /*
	     * Move the matched pattern to the first slot in the cache and
	     * shift the other patterns down one position.
	     */

	    if (i != 0) {
		int j;
		char *cachedString;

		cachedString = tsdPtr->patterns[i];
		regexpPtr = tsdPtr->regexps[i];
		for (j = i-1; j >= 0; j--) {
		    tsdPtr->patterns[j+1] = tsdPtr->patterns[j];
		    tsdPtr->patLengths[j+1] = tsdPtr->patLengths[j];
		    tsdPtr->regexps[j+1] = tsdPtr->regexps[j];
		}
		tsdPtr->patterns[0] = cachedString;
		tsdPtr->patLengths[0] = length;
		tsdPtr->regexps[0] = regexpPtr;
	    }
	    return tsdPtr->regexps[0];
	}
    }

    /*
     * This is a new expression, so compile it and add it to the cache.
     */

    regexpPtr = ckalloc(sizeof(TclRegexp));
    regexpPtr->objPtr = NULL;
    regexpPtr->string = NULL;
    regexpPtr->details.rm_extend.rm_so = -1;
    regexpPtr->details.rm_extend.rm_eo = -1;

    /*
     * Get the up-to-date string representation and map to unicode.
     */

    Tcl_DStringInit(&stringBuf);
    uniString = Tcl_UtfToUniCharDString(string, length, &stringBuf);
    numChars = Tcl_DStringLength(&stringBuf) / sizeof(Tcl_UniChar);

    /*
     * Compile the string and check for errors.
     */

    regexpPtr->flags = flags;
    status = TclReComp(&regexpPtr->re, uniString, (size_t) numChars, flags);
    Tcl_DStringFree(&stringBuf);

    if (status != REG_OKAY) {
	/*
	 * Clean up and report errors in the interpreter, if possible.
	 */

	ckfree(regexpPtr);
	if (interp) {
	    TclRegError(interp,
		    "couldn't compile regular expression pattern: ", status);
	}
	return NULL;
    }

    /*
     * Convert RE to a glob pattern equivalent, if any, and cache it.  If this
     * is not possible, then globObjPtr will be NULL.  This is used by
     * Tcl_RegExpExecObj to optionally do a fast match (avoids RE engine).
     */

    if (TclReToGlob(NULL, string, length, &stringBuf, &exact) == TCL_OK) {
	regexpPtr->globObjPtr = TclDStringToObj(&stringBuf);
	Tcl_IncrRefCount(regexpPtr->globObjPtr);
    } else {
	regexpPtr->globObjPtr = NULL;
    }

    /*
     * Allocate enough space for all of the subexpressions, plus one extra for
     * the entire pattern.
     */

    regexpPtr->matches =
	    ckalloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));

    /*
     * Initialize the refcount to one initially, since it is in the cache.
     */

    regexpPtr->refCount = 1;

    /*
     * Free the last regexp, if necessary, and make room at the head of the
     * list for the new regexp.
     */

    if (tsdPtr->patterns[NUM_REGEXPS-1] != NULL) {
	TclRegexp *oldRegexpPtr = tsdPtr->regexps[NUM_REGEXPS-1];

	if (--(oldRegexpPtr->refCount) <= 0) {
	    FreeRegexp(oldRegexpPtr);
	}
	ckfree(tsdPtr->patterns[NUM_REGEXPS-1]);
    }
    for (i = NUM_REGEXPS - 2; i >= 0; i--) {
	tsdPtr->patterns[i+1] = tsdPtr->patterns[i];
	tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i];
	tsdPtr->regexps[i+1] = tsdPtr->regexps[i];
    }
    tsdPtr->patterns[0] = ckalloc(length + 1);
    memcpy(tsdPtr->patterns[0], string, (unsigned) length + 1);
    tsdPtr->patLengths[0] = length;
    tsdPtr->regexps[0] = regexpPtr;

    return regexpPtr;
}