Example #1
0
const char *
Tcl_GetEncodingNameFromEnvironment(
    Tcl_DString *bufPtr)
{
    Tcl_DStringInit(bufPtr);
    Tcl_DStringSetLength(bufPtr, 2+TCL_INTEGER_SPACE);
    wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP());
    Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr)));
    return Tcl_DStringValue(bufPtr);
}
Example #2
0
int ScriptTcl::Tcl_replicaSendrecv(ClientData, Tcl_Interp *interp, int argc, char **argv) {
  if ( argc < 3 || argc > 4 ) {
    Tcl_SetResult(interp,"args: data dest ?source?",TCL_VOLATILE);
    return TCL_ERROR;
  }
  Tcl_DString recvstr;
  Tcl_DStringInit(&recvstr);
  int sendcount = strlen(argv[1]);
  int recvcount = 0;
  int dest = atoi(argv[2]);
  int source = -1;
  if ( argc > 3 ) source = atoi(argv[3]);
#if CMK_HAS_PARTITION
  if (dest == CmiMyPartition()) {
    Tcl_DStringSetLength(&recvstr,sendcount);
    memcpy(Tcl_DStringValue(&recvstr),argv[1],sendcount);
  } else {
    DataMessage *recvMsg = NULL;
    replica_sendRecv(argv[1], sendcount, dest, CkMyPe(), &recvMsg, source, CkMyPe());
    CmiAssert(recvMsg != NULL);
    Tcl_DStringAppend(&recvstr, recvMsg->data, recvMsg->size);
    CmiFree(recvMsg);
  }
#endif
  Tcl_DStringResult(interp, &recvstr);
  Tcl_DStringFree(&recvstr);
  return TCL_OK;
}
Example #3
0
File: tkWinSend.c Project: dgsb/tk
static HRESULT
RegisterInterp(
    const char *name,
    RegisteredInterp *riPtr)
{
    HRESULT hr = S_OK;
    LPRUNNINGOBJECTTABLE pROT = NULL;
    LPMONIKER pmk = NULL;
    int i, offset;
    const char *actualName = name;
    Tcl_DString dString;
    Tcl_DStringInit(&dString);

    hr = GetRunningObjectTable(0, &pROT);
    if (SUCCEEDED(hr)) {
	offset = 0;
	for (i = 1; SUCCEEDED(hr); i++) {
	    if (i > 1) {
		if (i == 2) {
		    Tcl_DStringInit(&dString);
		    Tcl_DStringAppend(&dString, name, -1);
		    Tcl_DStringAppend(&dString, " #", 2);
		    offset = Tcl_DStringLength(&dString);
		    Tcl_DStringSetLength(&dString, offset+TCL_INTEGER_SPACE);
		    actualName = Tcl_DStringValue(&dString);
		}
		sprintf(Tcl_DStringValue(&dString) + offset, "%d", i);
	    }

	    hr = BuildMoniker(actualName, &pmk);
	    if (SUCCEEDED(hr)) {

		hr = pROT->lpVtbl->Register(pROT,
		    ROTFLAGS_REGISTRATIONKEEPSALIVE,
		    riPtr->obj, pmk, &riPtr->cookie);

		pmk->lpVtbl->Release(pmk);
	    }

	    if (hr == MK_S_MONIKERALREADYREGISTERED) {
		pROT->lpVtbl->Revoke(pROT, riPtr->cookie);
	    } else if (hr == S_OK) {
		break;
	    }
	}

	pROT->lpVtbl->Release(pROT);
    }

    if (SUCCEEDED(hr)) {
	riPtr->name = strdup(actualName);
    }

    Tcl_DStringFree(&dString);
    return hr;
}
Example #4
0
/* convert to a string from a double */
Tcl_DString*
TSP_Util_lang_convert_string_double(Tcl_Interp* interp, Tcl_DString* targetVarName, double sourceVarName) {
    char str[500];
    if (targetVarName != NULL) {
        Tcl_DStringSetLength(targetVarName, 0);
    } else {
        targetVarName = (Tcl_DString*) ckalloc(sizeof(Tcl_DString));;
        Tcl_DStringInit(targetVarName);
    }
    Tcl_PrintDouble(interp, sourceVarName, str);
    Tcl_DStringAppend(targetVarName, str, -1);
    return targetVarName;
}
Example #5
0
/* string must be used immediately */
Tcl_DString*
TSP_Util_lang_get_string_double(double sourceVarName) {
    static int doInit = 1;
    static Tcl_DString ds;
    if (doInit) {
        Tcl_DStringInit(&ds);
        doInit = 0;
    } else {
        Tcl_DStringSetLength(&ds, 0);
    }
    TSP_Util_lang_convert_string_double(NULL, &ds, sourceVarName);
    return &ds;
}
Example #6
0
static void
CleanCache(Tcl_Interp *interp)
{
    NSVGcache *cachePtr = GetCachePtr(interp);

    if (cachePtr != NULL) {
        cachePtr->dataOrChan = NULL;
        Tcl_DStringSetLength(&cachePtr->formatString, 0);
	if (cachePtr->nsvgImage != NULL) {
	    nsvgDelete(cachePtr->nsvgImage);
	    cachePtr->nsvgImage = NULL;
	}
    }
}
Example #7
0
/* convert to a string from an int */
Tcl_DString*
TSP_Util_lang_convert_string_int(Tcl_Interp* interp, Tcl_DString* targetVarName, Tcl_WideInt sourceVarName) {
    char str[500];
    char *format = "%" TCL_LL_MODIFIER "d";
    if (targetVarName != NULL) {
        Tcl_DStringSetLength(targetVarName, 0);
    } else {
        targetVarName = (Tcl_DString*) ckalloc(sizeof(Tcl_DString));;
        Tcl_DStringInit(targetVarName);
    }
    sprintf(str, format, sourceVarName);
    Tcl_DStringAppend(targetVarName, str, -1);
    return targetVarName;
}
Example #8
0
/* convert to a string from a var */
Tcl_DString*
TSP_Util_lang_convert_string_var(Tcl_DString* targetVarName, Tcl_Obj* sourceVarName) {
    char* str;
    int len;
    if (targetVarName != NULL) {
        Tcl_DStringSetLength(targetVarName, 0);
    } else {
        targetVarName = (Tcl_DString*) ckalloc(sizeof(Tcl_DString));;
        Tcl_DStringInit(targetVarName);
    }
    str = Tcl_GetStringFromObj(sourceVarName, &len);
    Tcl_DStringAppend(targetVarName, str, len);
    return targetVarName;
}
Example #9
0
/* string must be used immediately */
Tcl_DString*
TSP_Util_lang_get_string_int(Tcl_WideInt sourceVarName) {
    static int doInit = 1;
    static Tcl_DString ds;
    Tcl_DString* dsPtr;
    if (doInit) {
        Tcl_DStringInit(&ds);
        doInit = 0;
    } else {
        Tcl_DStringSetLength(&ds, 0);
    }
    dsPtr = &ds;
    dsPtr = TSP_Util_lang_convert_string_int(NULL, dsPtr, sourceVarName);
    return dsPtr;
}
Example #10
0
/* string must be used immediately */
Tcl_DString*
TSP_Util_lang_get_string_var(Tcl_Obj* sourceVarName) {
    static int doInit = 1;
    static Tcl_DString ds;
    int len;
    char* str;
    if (doInit) {
        Tcl_DStringInit(&ds);
        doInit = 0;
    } else {
        Tcl_DStringSetLength(&ds, 0);
    }
    str = Tcl_GetStringFromObj(sourceVarName, &len);
    Tcl_DStringAppend(&ds, str, len);
    return &ds;
}
Example #11
0
static int 
TraverseWinTree(
    TraversalProc *traverseProc,/* Function to call for every file and
				 * directory in source hierarchy. */
    Tcl_DString *sourcePtr,	/* Pathname of source directory to be
				 * traversed. */
    Tcl_DString *targetPtr,	/* Pathname of directory to traverse in
				 * parallel with source directory. */
    Tcl_DString *errorPtr)	/* If non-NULL, an initialized DString for
				 * error reporting. */
{
    DWORD sourceAttr;
    char *source, *target, *errfile;
    int result, sourceLen, targetLen, sourceLenOriginal, targetLenOriginal;
    HANDLE handle;
    WIN32_FIND_DATA data;

    result = TCL_OK;
    source = Tcl_DStringValue(sourcePtr);
    sourceLenOriginal = Tcl_DStringLength(sourcePtr);
    if (targetPtr != NULL) {
	target = Tcl_DStringValue(targetPtr);
	targetLenOriginal = Tcl_DStringLength(targetPtr);
    } else {
	target = NULL;
	targetLenOriginal = 0;
    }

    errfile = NULL;

    sourceAttr = GetFileAttributes(source);
    if (sourceAttr == (DWORD) -1) {
	errfile = source;
	goto end;
    }
    if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
	/*
	 * Process the regular file
	 */

	return (*traverseProc)(source, target, sourceAttr, DOTREE_F, errorPtr);
    }

    /*
     * When given the pathname of the form "c:\" (one that already ends
     * with a backslash), must make sure not to add another "\" to the end
     * otherwise it will try to access a network drive.  
     */

    sourceLen = sourceLenOriginal;
    if ((sourceLen > 0) && (source[sourceLen - 1] != '\\')) {
	Tcl_DStringAppend(sourcePtr, "\\", 1);
	sourceLen++;
    }
    source = Tcl_DStringAppend(sourcePtr, "*.*", 3); 
    handle = FindFirstFile(source, &data);
    Tcl_DStringSetLength(sourcePtr, sourceLen);
    if (handle == INVALID_HANDLE_VALUE) {
	/* 
	 * Can't read directory
	 */

	TclWinConvertError(GetLastError());
	errfile = source;
	goto end;
    }

    result = (*traverseProc)(source, target, sourceAttr, DOTREE_PRED, errorPtr);
    if (result != TCL_OK) {
	FindClose(handle);
	return result;
    }

    if (targetPtr != NULL) {
	targetLen = targetLenOriginal;
	if ((targetLen > 0) && (target[targetLen - 1] != '\\')) {
	    target = Tcl_DStringAppend(targetPtr, "\\", 1);
	    targetLen++;
	}
    }

    while (1) {
	if ((strcmp(data.cFileName, ".") != 0)
	        && (strcmp(data.cFileName, "..") != 0)) {
	    /* 
	     * Append name after slash, and recurse on the file. 
	     */

	    Tcl_DStringAppend(sourcePtr, data.cFileName, -1);
	    if (targetPtr != NULL) {
		Tcl_DStringAppend(targetPtr, data.cFileName, -1);
	    }
	    result = TraverseWinTree(traverseProc, sourcePtr, targetPtr, 
		    errorPtr);
	    if (result != TCL_OK) {
		break;
	    }

	    /*
	     * Remove name after slash.
	     */

	    Tcl_DStringSetLength(sourcePtr, sourceLen);
	    if (targetPtr != NULL) {
		Tcl_DStringSetLength(targetPtr, targetLen);
	    }
	}
	if (FindNextFile(handle, &data) == FALSE) {
	    break;
	}
    }
    FindClose(handle);

    /*
     * Strip off the trailing slash we added
     */

    Tcl_DStringSetLength(sourcePtr, sourceLenOriginal);
    source = Tcl_DStringValue(sourcePtr);
    if (targetPtr != NULL) {
	Tcl_DStringSetLength(targetPtr, targetLenOriginal);
	target = Tcl_DStringValue(targetPtr);
    }

    if (result == TCL_OK) {
	/*
	 * Call traverseProc() on a directory after visiting all the
	 * files in that directory.
	 */

	result = (*traverseProc)(source, target, sourceAttr, 
		DOTREE_POSTD, errorPtr);
    }
    end:
    if (errfile != NULL) {
	TclWinConvertError(GetLastError());
	if (errorPtr != NULL) {
	    Tcl_DStringAppend(errorPtr, errfile, -1);
	}
	result = TCL_ERROR;
    }
	    
    return result;
}
Example #12
0
void
TclpFindExecutable(
    CONST char *argv0)		/* The value of the application's argv[0]
				 * (native). */
{
    CONST char *name, *p;
    Tcl_StatBuf statBuf;
    Tcl_DString buffer, nameString, cwd, utfName;
    Tcl_Encoding encoding;

    if (argv0 == NULL) {
        return;
    }
    Tcl_DStringInit(&buffer);

    name = argv0;
    for (p = name; *p != '\0'; p++) {
        if (*p == '/') {
            /*
             * The name contains a slash, so use the name directly without
             * doing a path search.
             */

            goto gotName;
        }
    }

    p = getenv("PATH");					/* INTL: Native. */
    if (p == NULL) {
        /*
         * There's no PATH environment variable; use the default that is used
         * by sh.
         */

        p = ":/bin:/usr/bin";
    } else if (*p == '\0') {
        /*
         * An empty path is equivalent to ".".
         */

        p = "./";
    }

    /*
     * Search through all the directories named in the PATH variable to see if
     * argv[0] is in one of them. If so, use that file name.
     */

    while (1) {
        while (TclIsSpaceProc(*p)) {
            p++;
        }
        name = p;
        while ((*p != ':') && (*p != 0)) {
            p++;
        }
        Tcl_DStringSetLength(&buffer, 0);
        if (p != name) {
            Tcl_DStringAppend(&buffer, name, p - name);
            if (p[-1] != '/') {
                Tcl_DStringAppend(&buffer, "/", 1);
            }
        }
        name = Tcl_DStringAppend(&buffer, argv0, -1);

        /*
         * INTL: The following calls to access() and stat() should not be
         * converted to Tclp routines because they need to operate on native
         * strings directly.
         */

        if ((access(name, X_OK) == 0)			/* INTL: Native. */
                && (TclOSstat(name, &statBuf) == 0)	/* INTL: Native. */
                && S_ISREG(statBuf.st_mode)) {
            goto gotName;
        }
        if (*p == '\0') {
            break;
        } else if (*(p+1) == 0) {
            p = "./";
        } else {
            p++;
        }
    }
    TclSetObjNameOfExecutable(Tcl_NewObj(), NULL);
    goto done;

    /*
     * If the name starts with "/" then just store it
     */

gotName:
#ifdef DJGPP
    if (name[1] == ':')
#else
    if (name[0] == '/')
#endif
    {
        encoding = Tcl_GetEncoding(NULL, NULL);
        Tcl_ExternalToUtfDString(encoding, name, -1, &utfName);
        TclSetObjNameOfExecutable(
            Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
        Tcl_DStringFree(&utfName);
        goto done;
    }

    /*
     * The name is relative to the current working directory. First strip off
     * a leading "./", if any, then add the full path name of the current
     * working directory.
     */

    if ((name[0] == '.') && (name[1] == '/')) {
        name += 2;
    }

    Tcl_DStringInit(&nameString);
    Tcl_DStringAppend(&nameString, name, -1);

    TclpGetCwd(NULL, &cwd);

    Tcl_DStringFree(&buffer);
    Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd),
                             Tcl_DStringLength(&cwd), &buffer);
    if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') {
        Tcl_DStringAppend(&buffer, "/", 1);
    }
    Tcl_DStringFree(&cwd);
    Tcl_DStringAppend(&buffer, Tcl_DStringValue(&nameString),
                      Tcl_DStringLength(&nameString));
    Tcl_DStringFree(&nameString);

    encoding = Tcl_GetEncoding(NULL, NULL);
    Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1,
                             &utfName);
    TclSetObjNameOfExecutable(
        Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
    Tcl_DStringFree(&utfName);

done:
    Tcl_DStringFree(&buffer);
}
Example #13
0
	/*ARGSUSED*/
static int
EmbWinLayoutProc(
    TkText *textPtr,		/* Text widget being layed out. */
    TkTextIndex *indexPtr,	/* Identifies first character in chunk. */
    TkTextSegment *ewPtr,	/* Segment corresponding to indexPtr. */
    int offset,			/* Offset within segPtr corresponding to
				 * indexPtr (always 0). */
    int maxX,			/* Chunk must not occupy pixels at this
				 * position or higher. */
    int maxChars,		/* Chunk must not include more than this many
				 * characters. */
    int noCharsYet,		/* Non-zero means no characters have been
				 * assigned to this line yet. */
    TkWrapMode wrapMode,	/* Wrap mode to use for line:
				 * TEXT_WRAPMODE_CHAR, TEXT_WRAPMODE_NONE, or
				 * TEXT_WRAPMODE_WORD. */
    register TkTextDispChunk *chunkPtr)
				/* Structure to fill in with information about
				 * this chunk. The x field has already been
				 * set by the caller. */
{
    int width, height;
    TkTextEmbWindowClient *client;

    if (offset != 0) {
	Tcl_Panic("Non-zero offset in EmbWinLayoutProc");
    }

    client = EmbWinGetClient(textPtr, ewPtr);
    if (client == NULL) {
	ewPtr->body.ew.tkwin = NULL;
    } else {
	ewPtr->body.ew.tkwin = client->tkwin;
    }

    if ((ewPtr->body.ew.tkwin == NULL) && (ewPtr->body.ew.create != NULL)) {
	int code, isNew;
	Tk_Window ancestor;
	Tcl_HashEntry *hPtr;
	const char *before, *string;
	Tcl_DString name, buf, *dsPtr = NULL;

	before = ewPtr->body.ew.create;

	/*
	 * Find everything up to the next % character and append it to the
	 * result string.
	 */

	string = before;
	while (*string != 0) {
	    if ((*string == '%') && (string[1] == '%' || string[1] == 'W')) {
		if (dsPtr == NULL) {
		    Tcl_DStringInit(&buf);
		    dsPtr = &buf;
		}
		if (string != before) {
		    Tcl_DStringAppend(dsPtr, before, (int) (string-before));
		    before = string;
		}
		if (string[1] == '%') {
		    Tcl_DStringAppend(dsPtr, "%", 1);
		} else {
		    /*
		     * Substitute string as proper Tcl list element.
		     */

		    int spaceNeeded, cvtFlags, length;
		    const char *str = Tk_PathName(textPtr->tkwin);

		    spaceNeeded = Tcl_ScanElement(str, &cvtFlags);
		    length = Tcl_DStringLength(dsPtr);
		    Tcl_DStringSetLength(dsPtr, length + spaceNeeded);
		    spaceNeeded = Tcl_ConvertElement(str,
			    Tcl_DStringValue(dsPtr) + length,
			    cvtFlags | TCL_DONT_USE_BRACES);
		    Tcl_DStringSetLength(dsPtr, length + spaceNeeded);
		}
		before += 2;
		string++;
	    }
	    string++;
	}

	/*
	 * The window doesn't currently exist. Create it by evaluating the
	 * creation script. The script must return the window's path name:
	 * look up that name to get back to the window token. Then register
	 * ourselves as the geometry manager for the window.
	 */

	if (dsPtr != NULL) {
	    Tcl_DStringAppend(dsPtr, before, (int) (string-before));
	    code = Tcl_GlobalEval(textPtr->interp, Tcl_DStringValue(dsPtr));
	    Tcl_DStringFree(dsPtr);
	} else {
	    code = Tcl_GlobalEval(textPtr->interp, ewPtr->body.ew.create);
	}
	if (code != TCL_OK) {
	createError:
	    Tcl_BackgroundException(textPtr->interp, code);
	    goto gotWindow;
	}
	Tcl_DStringInit(&name);
	Tcl_DStringAppend(&name, Tcl_GetStringResult(textPtr->interp), -1);
	Tcl_ResetResult(textPtr->interp);
	ewPtr->body.ew.tkwin = Tk_NameToWindow(textPtr->interp,
		Tcl_DStringValue(&name), textPtr->tkwin);
	Tcl_DStringFree(&name);
	if (ewPtr->body.ew.tkwin == NULL) {
	    goto createError;
	}
	for (ancestor = textPtr->tkwin; ; ancestor = Tk_Parent(ancestor)) {
	    if (ancestor == Tk_Parent(ewPtr->body.ew.tkwin)) {
		break;
	    }
	    if (Tk_TopWinHierarchy(ancestor)) {
	    badMaster:
		Tcl_AppendResult(textPtr->interp, "can't embed ",
			Tk_PathName(ewPtr->body.ew.tkwin), " relative to ",
			Tk_PathName(textPtr->tkwin), NULL);
		Tcl_BackgroundError(textPtr->interp);
		ewPtr->body.ew.tkwin = NULL;
		goto gotWindow;
	    }
	}
	if (Tk_TopWinHierarchy(ewPtr->body.ew.tkwin)
		|| (textPtr->tkwin == ewPtr->body.ew.tkwin)) {
	    goto badMaster;
	}

	if (client == NULL) {
	    /*
	     * We just used a '-create' script to make a new window, which we
	     * now need to add to our client list.
	     */

	    client = (TkTextEmbWindowClient *)
		    ckalloc(sizeof(TkTextEmbWindowClient));
	    client->next = ewPtr->body.ew.clients;
	    client->textPtr = textPtr;
	    client->tkwin = NULL;
	    client->chunkCount = 0;
	    client->displayed = 0;
	    client->parent = ewPtr;
	    ewPtr->body.ew.clients = client;
	}

	client->tkwin = ewPtr->body.ew.tkwin;
	Tk_ManageGeometry(client->tkwin, &textGeomType, client);
	Tk_CreateEventHandler(client->tkwin, StructureNotifyMask,
		EmbWinStructureProc, client);

	/*
	 * Special trick! Must enter into the hash table *after* calling
	 * Tk_ManageGeometry: if the window was already managed elsewhere in
	 * this text, the Tk_ManageGeometry call will cause the entry to be
	 * removed, which could potentially lose the new entry.
	 */

	hPtr = Tcl_CreateHashEntry(&textPtr->sharedTextPtr->windowTable,
		Tk_PathName(client->tkwin), &isNew);
	Tcl_SetHashValue(hPtr, ewPtr);
    }

    /*
     * See if there's room for this window on this line.
     */

  gotWindow:
    if (ewPtr->body.ew.tkwin == NULL) {
	width = 0;
	height = 0;
    } else {
	width = Tk_ReqWidth(ewPtr->body.ew.tkwin) + 2*ewPtr->body.ew.padX;
	height = Tk_ReqHeight(ewPtr->body.ew.tkwin) + 2*ewPtr->body.ew.padY;
    }
    if ((width > (maxX - chunkPtr->x))
	    && !noCharsYet && (textPtr->wrapMode != TEXT_WRAPMODE_NONE)) {
	return 0;
    }

    /*
     * Fill in the chunk structure.
     */

    chunkPtr->displayProc = TkTextEmbWinDisplayProc;
    chunkPtr->undisplayProc = EmbWinUndisplayProc;
    chunkPtr->measureProc = NULL;
    chunkPtr->bboxProc = EmbWinBboxProc;
    chunkPtr->numBytes = 1;
    if (ewPtr->body.ew.align == ALIGN_BASELINE) {
	chunkPtr->minAscent = height - ewPtr->body.ew.padY;
	chunkPtr->minDescent = ewPtr->body.ew.padY;
	chunkPtr->minHeight = 0;
    } else {
	chunkPtr->minAscent = 0;
	chunkPtr->minDescent = 0;
	chunkPtr->minHeight = height;
    }
    chunkPtr->width = width;
    chunkPtr->breakIndex = -1;
    chunkPtr->breakIndex = 1;
    chunkPtr->clientData = ewPtr;
    if (client != NULL) {
	client->chunkCount += 1;
    }
    return 1;
}
Example #14
0
const char *
TkpGetString(
    TkWindow *winPtr,		/* Window where event occurred */
    XEvent *eventPtr,		/* X keyboard event. */
    Tcl_DString *dsPtr)		/* Initialized, empty string to hold result. */
{
    int len;
    Tcl_DString buf;
    TkKeyEvent *kePtr = (TkKeyEvent *) eventPtr;

    /*
     * If we have the value cached already, use it now. [Bug 1373712]
     */

    if (kePtr->charValuePtr != NULL) {
	Tcl_DStringSetLength(dsPtr, kePtr->charValueLen);
	memcpy(Tcl_DStringValue(dsPtr), kePtr->charValuePtr,
		(unsigned) kePtr->charValueLen+1);
	return Tcl_DStringValue(dsPtr);
    }

#ifdef TK_USE_INPUT_METHODS
    if ((winPtr->dispPtr->flags & TK_DISPLAY_USE_IM)
	    && (winPtr->inputContext != NULL)
	    && (eventPtr->type == KeyPress)) {
	Status status;

#if X_HAVE_UTF8_STRING
	Tcl_DStringSetLength(dsPtr, TCL_DSTRING_STATIC_SIZE-1);
	len = Xutf8LookupString(winPtr->inputContext, &eventPtr->xkey,
		Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr),
		&kePtr->keysym, &status);

	if (status == XBufferOverflow) {
	    /*
	     * Expand buffer and try again.
	     */

	    Tcl_DStringSetLength(dsPtr, len);
	    len = Xutf8LookupString(winPtr->inputContext, &eventPtr->xkey,
		    Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr),
		    &kePtr->keysym, &status);
	}
	if ((status != XLookupChars) && (status != XLookupBoth)) {
	    len = 0;
	}
	Tcl_DStringSetLength(dsPtr, len);
#else /* !X_HAVE_UTF8_STRING */
	/*
	 * Overallocate the dstring to the maximum stack amount.
	 */

	Tcl_DStringInit(&buf);
	Tcl_DStringSetLength(&buf, TCL_DSTRING_STATIC_SIZE-1);
	len = XmbLookupString(winPtr->inputContext, &eventPtr->xkey,
		Tcl_DStringValue(&buf), Tcl_DStringLength(&buf),
                &kePtr->keysym, &status);

	/*
	 * If the buffer wasn't big enough, grow the buffer and try again.
	 */

	if (status == XBufferOverflow) {
	    Tcl_DStringSetLength(&buf, len);
	    len = XmbLookupString(winPtr->inputContext, &eventPtr->xkey,
		    Tcl_DStringValue(&buf), len, &kePtr->keysym, &status);
	}
	if ((status != XLookupChars) && (status != XLookupBoth)) {
	    len = 0;
	}
	Tcl_DStringSetLength(&buf, len);
	Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&buf), len, dsPtr);
	Tcl_DStringFree(&buf);
#endif /* X_HAVE_UTF8_STRING */
    } else
#endif /* TK_USE_INPUT_METHODS */
    {
	/*
	 * Fall back to convert a keyboard event to a UTF-8 string using
	 * XLookupString. This is used when input methods are turned off and
	 * for KeyRelease events.
	 *
	 * Note: XLookupString() normally returns a single ISO Latin 1 or
	 * ASCII control character.
	 */

	Tcl_DStringInit(&buf);
	Tcl_DStringSetLength(&buf, TCL_DSTRING_STATIC_SIZE-1);
	len = XLookupString(&eventPtr->xkey, Tcl_DStringValue(&buf),
		TCL_DSTRING_STATIC_SIZE, &kePtr->keysym, 0);
	Tcl_DStringValue(&buf)[len] = '\0';

	if (len == 1) {
	    len = Tcl_UniCharToUtf((unsigned char) Tcl_DStringValue(&buf)[0],
		    Tcl_DStringValue(dsPtr));
	    Tcl_DStringSetLength(dsPtr, len);
	} else {
	    /*
	     * len > 1 should only happen if someone has called XRebindKeysym.
	     * Assume UTF-8.
	     */

	    Tcl_DStringSetLength(dsPtr, len);
	    strncpy(Tcl_DStringValue(dsPtr), Tcl_DStringValue(&buf), len);
	}
    }

    /*
     * Cache the string in the event so that if/when we return to this
     * function, we will be able to produce it without asking X. This stops us
     * from having to reenter the XIM engine. [Bug 1373712]
     */

    kePtr->charValuePtr = ckalloc(len + 1);
    kePtr->charValueLen = len;
    memcpy(kePtr->charValuePtr, Tcl_DStringValue(dsPtr), (unsigned) len + 1);
    return Tcl_DStringValue(dsPtr);
}
Example #15
0
int
TclpFindVariable(
    const char *name,		/* Name of desired environment variable
				 * (UTF-8). */
    int *lengthPtr)		/* Used to return length of name (for
				 * successful searches) or number of non-NULL
				 * entries in environ (for unsuccessful
				 * searches). */
{
    int i, length, result = -1;
    register const char *env, *p1, *p2;
    char *envUpper, *nameUpper;
    Tcl_DString envString;

    /*
     * Convert the name to all upper case for the case insensitive comparison.
     */

    length = strlen(name);
    nameUpper = (char *) ckalloc((unsigned) length+1);
    memcpy(nameUpper, name, (size_t) length+1);
    Tcl_UtfToUpper(nameUpper);

    Tcl_DStringInit(&envString);
    for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
	/*
	 * Chop the env string off after the equal sign, then Convert the name
	 * to all upper case, so we do not have to convert all the characters
	 * after the equal sign.
	 */

	envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
	p1 = strchr(envUpper, '=');
	if (p1 == NULL) {
	    continue;
	}
	length = (int) (p1 - envUpper);
	Tcl_DStringSetLength(&envString, length+1);
	Tcl_UtfToUpper(envUpper);

	p1 = envUpper;
	p2 = nameUpper;
	for (; *p2 == *p1; p1++, p2++) {
	    /* NULL loop body. */
	}
	if ((*p1 == '=') && (*p2 == '\0')) {
	    *lengthPtr = length;
	    result = i;
	    goto done;
	}

	Tcl_DStringFree(&envString);
    }

    *lengthPtr = i;

  done:
    Tcl_DStringFree(&envString);
    ckfree(nameUpper);
    return result;
}
Example #16
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;
}
Example #17
0
static int 
TraverseWinTree(
    TraversalProc *traverseProc,/* Function to call for every file and
				 * directory in source hierarchy. */
    Tcl_DString *sourcePtr,	/* Pathname of source directory to be
				 * traversed (native). */
    Tcl_DString *targetPtr,	/* Pathname of directory to traverse in
				 * parallel with source directory (native). */
    Tcl_DString *errorPtr)	/* If non-NULL, uninitialized or free
				 * DString filled with UTF-8 name of file
				 * causing error. */
{
    DWORD sourceAttr;
    TCHAR *nativeSource, *nativeErrfile;
    int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen;
    HANDLE handle;
    WIN32_FIND_DATAT data;

    nativeErrfile = NULL;
    result = TCL_OK;
    oldTargetLen = 0;		/* lint. */

    nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
    oldSourceLen = Tcl_DStringLength(sourcePtr);
    sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource);
    if (sourceAttr == 0xffffffff) {
	nativeErrfile = nativeSource;
	goto end;
    }
    if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
	/*
	 * Process the regular file
	 */

	return (*traverseProc)(sourcePtr, targetPtr, DOTREE_F, errorPtr);
    }

    if (tclWinProcs->useWide) {
	Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
	Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
    } else {
	Tcl_DStringAppend(sourcePtr, "\\*.*", 4);
    }
    nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
    handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data);
    if (handle == INVALID_HANDLE_VALUE) {      
	/* 
	 * Can't read directory
	 */

	TclWinConvertError(GetLastError());
	nativeErrfile = nativeSource;
	goto end;
    }

    nativeSource[oldSourceLen + 1] = '\0';
    Tcl_DStringSetLength(sourcePtr, oldSourceLen);
    result = (*traverseProc)(sourcePtr, targetPtr, DOTREE_PRED, errorPtr);
    if (result != TCL_OK) {
	FindClose(handle);
	return result;
    }

    sourceLen = oldSourceLen;

    if (tclWinProcs->useWide) {
	sourceLen += sizeof(WCHAR);
	Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1);
	Tcl_DStringSetLength(sourcePtr, sourceLen);
    } else {
	sourceLen += 1;
	Tcl_DStringAppend(sourcePtr, "\\", 1);
    }
    if (targetPtr != NULL) {
	oldTargetLen = Tcl_DStringLength(targetPtr);

	targetLen = oldTargetLen;
	if (tclWinProcs->useWide) {
	    targetLen += sizeof(WCHAR);
	    Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
	    Tcl_DStringSetLength(targetPtr, targetLen);
	} else {
	    targetLen += 1;
	    Tcl_DStringAppend(targetPtr, "\\", 1);
	}
    }

    found = 1;
    for ( ; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
	TCHAR *nativeName;
	int len;

	if (tclWinProcs->useWide) {
	    WCHAR *wp;

	    wp = data.w.cFileName;
	    if (*wp == '.') {
		wp++;
		if (*wp == '.') {
		    wp++;
		}
		if (*wp == '\0') {
		    continue;
		}
	    }
	    nativeName = (TCHAR *) data.w.cFileName;
	    len = Tcl_UniCharLen(data.w.cFileName) * sizeof(WCHAR);
	} else {
	    if ((strcmp(data.a.cFileName, ".") == 0) 
		    || (strcmp(data.a.cFileName, "..") == 0)) {
		continue;
	    }
	    nativeName = (TCHAR *) data.a.cFileName;
	    len = strlen(data.a.cFileName);
	}

	/* 
	 * Append name after slash, and recurse on the file. 
	 */

	Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1);
	Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
	if (targetPtr != NULL) {
	    Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1);
	    Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1);
	}
	result = TraverseWinTree(traverseProc, sourcePtr, targetPtr, 
		errorPtr);
	if (result != TCL_OK) {
	    break;
	}

	/*
	 * Remove name after slash.
	 */

	Tcl_DStringSetLength(sourcePtr, sourceLen);
	if (targetPtr != NULL) {
	    Tcl_DStringSetLength(targetPtr, targetLen);
	}
    }
    FindClose(handle);

    /*
     * Strip off the trailing slash we added
     */

    Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1);
    Tcl_DStringSetLength(sourcePtr, oldSourceLen);
    if (targetPtr != NULL) {
	Tcl_DStringSetLength(targetPtr, oldTargetLen + 1);
	Tcl_DStringSetLength(targetPtr, oldTargetLen);
    }
    if (result == TCL_OK) {
	/*
	 * Call traverseProc() on a directory after visiting all the
	 * files in that directory.
	 */

	result = (*traverseProc)(sourcePtr, targetPtr, DOTREE_POSTD, 
		errorPtr);
    }
    end:
    if (nativeErrfile != NULL) {
	TclWinConvertError(GetLastError());
	if (errorPtr != NULL) {
	    Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr);
	}
	result = TCL_ERROR;
    }
	    
    return result;
}
Example #18
0
char *
Tk_SetAppName(
    Tk_Window tkwin,		/* Token for any window in the application
				 * to be named:  it is just used to identify
				 * the application and the display.  */
    char *name)			/* The name that will be used to
				 * refer to the interpreter in later
				 * "send" commands.  Must be globally
				 * unique. */
{
    TkWindow *winPtr = (TkWindow *) tkwin;
    Tcl_Interp *interp = winPtr->mainPtr->interp;
    int i, suffix, offset, result;
    int createCommand = 0;
    RegisteredInterp *riPtr, *prevPtr;
    char *actualName;
    Tcl_DString dString;
    Tcl_Obj *resultObjPtr, *interpNamePtr;
    char *interpName;

    if (!initialized) {
	SendInit(interp);
    }

    /*
     * See if the application is already registered; if so, remove its
     * current name from the registry. The deletion of the command
     * will take care of disposing of this entry.
     */

    for (riPtr = interpListPtr, prevPtr = NULL; riPtr != NULL; 
	    prevPtr = riPtr, riPtr = riPtr->nextPtr) {
	if (riPtr->interp == interp) {
	    if (prevPtr == NULL) {
		interpListPtr = interpListPtr->nextPtr;
	    } else {
		prevPtr->nextPtr = riPtr->nextPtr;
	    }
	    break;
	}
    }

    /*
     * Pick a name to use for the application.  Use "name" if it's not
     * already in use.  Otherwise add a suffix such as " #2", trying
     * larger and larger numbers until we eventually find one that is
     * unique.
     */

    actualName = name;
    suffix = 1;
    offset = 0;
    Tcl_DStringInit(&dString);

    TkGetInterpNames(interp, tkwin);
    resultObjPtr = Tcl_GetObjResult(interp);
    Tcl_IncrRefCount(resultObjPtr);
    for (i = 0; ; ) {
	result = Tcl_ListObjIndex(NULL, resultObjPtr, i, &interpNamePtr);
	if (interpNamePtr == NULL) {
	    break;
	}
	interpName = Tcl_GetStringFromObj(interpNamePtr, NULL);
	if (strcmp(actualName, interpName) == 0) {
	    if (suffix == 1) {
		Tcl_DStringAppend(&dString, name, -1);
		Tcl_DStringAppend(&dString, " #", 2);
		offset = Tcl_DStringLength(&dString);
		Tcl_DStringSetLength(&dString, offset + 10);
		actualName = Tcl_DStringValue(&dString);
	    }
	    suffix++;
	    sprintf(actualName + offset, "%d", suffix);
	    i = 0;
	} else {
	    i++;
	}
    }

    Tcl_DecrRefCount(resultObjPtr);
    Tcl_ResetResult(interp);

    /*
     * We have found a unique name. Now add it to the registry.
     */

    riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
    riPtr->interp = interp;
    riPtr->name = ckalloc(strlen(actualName) + 1);
    riPtr->nextPtr = interpListPtr;
    interpListPtr = riPtr;
    strcpy(riPtr->name, actualName);

    Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, 
	    (ClientData) riPtr, NULL /* TODO: DeleteProc */);
    if (Tcl_IsSafe(interp)) {
	Tcl_HideCommand(interp, "send", "send");
    }
    Tcl_DStringFree(&dString);

    return riPtr->name;
}
static AP_Result built_interp(AP_World *w, Tcl_Interp **interpretor, AP_Obj *interp_name)
{
	Tcl_Interp *interp;
	char name[128];
	const char *namep;
	Tcl_HashEntry *entry;
	int is_new, pre_named;
	AP_Type type;
	int r;

	type = AP_ObjType(w, *interp_name);
	
	if (type != AP_VARIABLE && type != AP_ATOM) { 
		AP_SetStandardError(w, AP_TYPE_ERROR,
					AP_NewSymbolFromStr(w, "atom_or_variable"), *interp_name);
		goto error;
	}
	
	pre_named = (type == AP_ATOM);

#ifdef macintosh
//	Tcl_MacSetEventProc(MyConvertEvent);
//	SIOUXSetEventVector(MyHandleOneEvent);
#endif

	interp = Tcl_CreateInterp();
	if (!interp) {
		AP_SetStandardError(w, AP_RESOURCE_ERROR, AP_NewSymbolFromStr(w, "tcl_memory"));
		goto error;
	}

/*
The following was causing a coredump on Mac OS X 10.5, and isn't necessary when
using the OS's Tcl/TK. Turned off for the moment.
TODO figure out why this is crashing on 10.5 - CEH 2009
*/
#if 0
	{
		Tcl_DString path;
		const char *elements[3];
		Tcl_DStringInit(&path);
		elements[0] = library_dir;
#ifdef macintosh
		elements[1] = "Tool Command Language";
#else
		elements[1] = "lib";
#endif
		elements[2] = "tcl" TCL_VERSION;
		Tcl_JoinPath(3, (char **)elements, &path);
		Tcl_SetVar(interp, (char *)"tcl_library", path.string, TCL_GLOBAL_ONLY);
		Tcl_DStringSetLength(&path, 0);
		Tcl_JoinPath(2, (char **)elements, &path);
		Tcl_SetVar(interp, (char *)"tcl_pkgPath", path.string, TCL_GLOBAL_ONLY|TCL_LIST_ELEMENT);
		Tcl_SetVar(interp, (char *)"autopath", (char *)"", TCL_GLOBAL_ONLY);
		Tcl_DStringFree(&path);
	}
#endif
	
	r = Tcl_Init(interp);

	if (r != TCL_OK) {
		TclToPrologResult(w, NULL, interp, r);
		goto error_delete;
	}

#ifdef ITCL
	r = Itcl_Init(interp);

	if (r != TCL_OK) {
		TclToPrologResult(w, NULL, interp, r);
		goto error_delete;
	}
	Tcl_StaticPackage(interp, (char *)"Itcl", Itcl_Init, Itcl_SafeInit);

	r = Tcl_Import(interp, Tcl_GetGlobalNamespace(interp),
		       (char *)"::itcl::*", /* allowOverwrite */ 1);

	if (r != TCL_OK) {
	  TclToPrologResult(w, NULL, interp, r);
	  goto error_delete;
	}

	r = Tcl_Eval(interp,
(char *)"auto_mkindex_parser::slavehook { _%@namespace import -force ::itcl::* }");

	if (r != TCL_OK) {
	  TclToPrologResult(w, NULL, interp, r);
	  goto error_delete;
	}
#endif

	if (pre_named) {
		namep = AP_GetAtomStr(w, *interp_name);
	} else {
		interp_count++;
		sprintf(name, "tcl_interp%d", interp_count);
		/* handle error */
		namep = name;
	}
	
	entry = Tcl_CreateHashEntry(&tcl_interp_name_table, namep, &is_new);
	if (!entry) {
		AP_SetStandardError(w, AP_RESOURCE_ERROR, AP_NewSymbolFromStr(w, "tcl_memory"));
		goto error_delete;
	}
	
	if (!is_new) {
		AP_SetStandardError(w, AP_PERMISSION_ERROR,
					AP_NewSymbolFromStr(w, "create"),
					AP_NewSymbolFromStr(w, "tcl_interpreter"), *interp_name);
		goto error_delete;
	} 			
	
	Tcl_SetHashValue(entry, interp);


	if (ALSProlog_Package_Init(interp, w) != TCL_OK) {
		AP_SetError(w, AP_NewSymbolFromStr(w, "tcl_create_command_error"));
		goto error_delete;
	}

	*interpretor = interp;

	return (pre_named) ? AP_SUCCESS : AP_Unify(w, *interp_name, AP_NewUIAFromStr(w, namep));
	
error_delete:
	Tcl_DeleteInterp(interp);
error:
	return AP_EXCEPTION;
}