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);
}
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;
}
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;
}
/* 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;
}
/* 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;
}
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;
}
}
}
/* 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;
}
/* 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;
}
/* 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;
}
/* 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;
}
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;
}
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);
}
/*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;
}
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);
}
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;
}
int
TclpMatchInDirectory(
Tcl_Interp *interp, /* Interpreter to receive errors. */
Tcl_Obj *resultPtr, /* List object to lappend results. */
Tcl_Obj *pathPtr, /* Contains path to directory to search. */
const char *pattern, /* Pattern to match against. */
Tcl_GlobTypeData *types) /* Object containing list of acceptable types.
* May be NULL. In particular the directory
* flag is very important. */
{
const char *native;
Tcl_Obj *fileNamePtr;
int matchResult = 0;
if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {
/*
* The native filesystem never adds mounts.
*/
return TCL_OK;
}
fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (fileNamePtr == NULL) {
return TCL_ERROR;
}
if (pattern == NULL || (*pattern == '\0')) {
/*
* Match a file directly.
*/
Tcl_Obj *tailPtr;
const char *nativeTail;
native = Tcl_FSGetNativePath(pathPtr);
tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL);
nativeTail = Tcl_FSGetNativePath(tailPtr);
matchResult = NativeMatchType(interp, native, nativeTail, types);
if (matchResult == 1) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
Tcl_DecrRefCount(tailPtr);
Tcl_DecrRefCount(fileNamePtr);
} else {
DIR *d;
Tcl_DirEntry *entryPtr;
const char *dirName;
int dirLength, nativeDirLen;
int matchHidden, matchHiddenPat;
Tcl_StatBuf statBuf;
Tcl_DString ds; /* native encoding of dir */
Tcl_DString dsOrig; /* utf-8 encoding of dir */
Tcl_DStringInit(&dsOrig);
dirName = TclGetStringFromObj(fileNamePtr, &dirLength);
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
/*
* Make sure that the directory part of the name really is a
* directory. If the directory name is "", use the name "." instead,
* because some UNIX systems don't treat "" like "." automatically.
* Keep the "" for use in generating file names, otherwise "glob
* foo.c" would return "./foo.c".
*/
if (dirLength == 0) {
dirName = ".";
} else {
dirName = Tcl_DStringValue(&dsOrig);
/*
* Make sure we have a trailing directory delimiter.
*/
if (dirName[dirLength-1] != '/') {
dirName = TclDStringAppendLiteral(&dsOrig, "/");
dirLength++;
}
}
/*
* Now open the directory for reading and iterate over the contents.
*/
native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);
if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */
|| !S_ISDIR(statBuf.st_mode)) {
Tcl_DStringFree(&dsOrig);
Tcl_DStringFree(&ds);
Tcl_DecrRefCount(fileNamePtr);
return TCL_OK;
}
d = opendir(native); /* INTL: Native. */
if (d == NULL) {
Tcl_DStringFree(&ds);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read directory \"%s\": %s",
Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp)));
}
Tcl_DStringFree(&dsOrig);
Tcl_DecrRefCount(fileNamePtr);
return TCL_ERROR;
}
nativeDirLen = Tcl_DStringLength(&ds);
/*
* Check to see if -type or the pattern requests hidden files.
*/
matchHiddenPat = (pattern[0] == '.')
|| ((pattern[0] == '\\') && (pattern[1] == '.'));
matchHidden = matchHiddenPat
|| (types && (types->perm & TCL_GLOB_PERM_HIDDEN));
while ((entryPtr = TclOSreaddir(d)) != NULL) { /* INTL: Native. */
Tcl_DString utfDs;
const char *utfname;
/*
* Skip this file if it doesn't agree with the hidden parameters
* requested by the user (via -type or pattern).
*/
if (*entryPtr->d_name == '.') {
if (!matchHidden) {
continue;
}
} else {
#ifdef MAC_OSX_TCL
if (matchHiddenPat) {
continue;
}
/* Also need to check HFS hidden flag in TclMacOSXMatchType. */
#else
if (matchHidden) {
continue;
}
#endif
}
/*
* Now check to see if the file matches, according to both type
* and pattern. If so, add the file to the result.
*/
utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1,
&utfDs);
if (Tcl_StringCaseMatch(utfname, pattern, 0)) {
int typeOk = 1;
if (types != NULL) {
Tcl_DStringSetLength(&ds, nativeDirLen);
native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1);
matchResult = NativeMatchType(interp, native,
entryPtr->d_name, types);
typeOk = (matchResult == 1);
}
if (typeOk) {
Tcl_ListObjAppendElement(interp, resultPtr,
TclNewFSPathObj(pathPtr, utfname,
Tcl_DStringLength(&utfDs)));
}
}
Tcl_DStringFree(&utfDs);
if (matchResult < 0) {
break;
}
}
closedir(d);
Tcl_DStringFree(&ds);
Tcl_DStringFree(&dsOrig);
Tcl_DecrRefCount(fileNamePtr);
}
if (matchResult < 0) {
return TCL_ERROR;
}
return TCL_OK;
}
static int
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;
}
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;
}