static int
TeststringobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar *unicode;
int varIndex, option, i, length;
#define MAX_STRINGS 11
const char *index, *string, *strings[MAX_STRINGS+1];
TestString *strPtr;
static const char *const options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
"set", "set2", "setlength", "maxchars", "getunicode",
"appendself", "appendself2", NULL
};
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option)
!= TCL_OK) {
return TCL_ERROR;
}
switch (option) {
case 0: /* append */
if (objc != 5) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
string = Tcl_GetString(objv[3]);
Tcl_AppendToObj(varPtr[varIndex], string, length);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 1: /* appendstrings */
if (objc > (MAX_STRINGS+3)) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
for (i = 3; i < objc; i++) {
strings[i-3] = Tcl_GetString(objv[i]);
}
for ( ; i < 12 + 3; i++) {
strings[i - 3] = NULL;
}
Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
strings[2], strings[3], strings[4], strings[5],
strings[6], strings[7], strings[8], strings[9],
strings[10], strings[11]);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 2: /* get */
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 3: /* get2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(varPtr[varIndex]);
Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
break;
case 4: /* length */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
? varPtr[varIndex]->length : -1);
break;
case 5: /* length2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (TestString *)
(varPtr[varIndex])->internalRep.otherValuePtr;
length = (int) strPtr->allocated;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 6: /* set */
if (objc != 4) {
goto wrongNumArgs;
}
/*
* If the object currently bound to the variable with index
* varIndex has ref count 1 (i.e. the object is unshared) we can
* modify that object directly. Otherwise, if RC>1 (i.e. the
* object is shared), we must create a new object to modify/set
* and decrement the old formerly-shared object's ref count. This
* is "copy on write".
*/
string = Tcl_GetStringFromObj(objv[3], &length);
if ((varPtr[varIndex] != NULL)
&& !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetStringObj(varPtr[varIndex], string, length);
} else {
SetVarToObj(varIndex, Tcl_NewStringObj(string, length));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 7: /* set2 */
if (objc != 4) {
goto wrongNumArgs;
}
SetVarToObj(varIndex, objv[3]);
break;
case 8: /* setlength */
if (objc != 4) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] != NULL) {
Tcl_SetObjLength(varPtr[varIndex], length);
}
break;
case 9: /* maxchars */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (TestString *)
(varPtr[varIndex])->internalRep.otherValuePtr;
length = strPtr->maxChars;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 10: /* getunicode */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL);
break;
case 11: /* appendself */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
string = Tcl_GetStringFromObj(varPtr[varIndex], &length);
if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
return TCL_ERROR;
}
if ((i < 0) || (i > length)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
Tcl_AppendToObj(varPtr[varIndex], string + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 12: /* appendself2 */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length);
if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
return TCL_ERROR;
}
if ((i < 0) || (i > length)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
}
return TCL_OK;
}
extern void getLabFromList (LPcmsCIELab Lab,Tcl_Obj **list) {
Lab->L=atof(Tcl_GetString(list[0]));
Lab->a=atof(Tcl_GetString(list[1]));
Lab->b=atof(Tcl_GetString(list[2]));
return;
}
extern void getLChFromList (LPcmsCIELCh LCh,Tcl_Obj **list) {
LCh->L=atof(Tcl_GetString(list[0]));
LCh->C=atof(Tcl_GetString(list[1]));
LCh->h=atof(Tcl_GetString(list[2]));
return;
}
/*
** Implementation of a special SQL scalar function for testing tokenizers
** designed to be used in concert with the Tcl testing framework. This
** function must be called with two arguments:
**
** SELECT <function-name>(<key-name>, <input-string>);
** SELECT <function-name>(<key-name>, <pointer>);
**
** where <function-name> is the name passed as the second argument
** to the sqlite3Fts3InitHashTable() function (e.g. 'fts3_tokenizer')
** concatenated with the string '_test' (e.g. 'fts3_tokenizer_test').
**
** The return value is a string that may be interpreted as a Tcl
** list. For each token in the <input-string>, three elements are
** added to the returned list. The first is the token position, the
** second is the token text (folded, stemmed, etc.) and the third is the
** substring of <input-string> associated with the token. For example,
** using the built-in "simple" tokenizer:
**
** SELECT fts_tokenizer_test('simple', 'I don't see how');
**
** will return the string:
**
** "{0 i I 1 dont don't 2 see see 3 how how}"
**
*/
static void testFunc(
sqlite3_context *context,
int argc,
sqlite3_value **argv
){
Fts3Hash *pHash;
sqlite3_tokenizer_module *p;
sqlite3_tokenizer *pTokenizer = 0;
sqlite3_tokenizer_cursor *pCsr = 0;
const char *zErr = 0;
const char *zName;
int nName;
const char *zInput;
int nInput;
const char *zArg = 0;
const char *zToken;
int nToken;
int iStart;
int iEnd;
int iPos;
Tcl_Obj *pRet;
assert( argc==2 || argc==3 );
nName = sqlite3_value_bytes(argv[0]);
zName = (const char *)sqlite3_value_text(argv[0]);
nInput = sqlite3_value_bytes(argv[argc-1]);
zInput = (const char *)sqlite3_value_text(argv[argc-1]);
if( argc==3 ){
zArg = (const char *)sqlite3_value_text(argv[1]);
}
pHash = (Fts3Hash *)sqlite3_user_data(context);
p = (sqlite3_tokenizer_module *)sqlite3Fts3HashFind(pHash, zName, nName+1);
if( !p ){
char *zErr = sqlite3_mprintf("unknown tokenizer: %s", zName);
sqlite3_result_error(context, zErr, -1);
sqlite3_free(zErr);
return;
}
pRet = Tcl_NewObj();
Tcl_IncrRefCount(pRet);
if( SQLITE_OK!=p->xCreate(zArg ? 1 : 0, &zArg, &pTokenizer) ){
zErr = "error in xCreate()";
goto finish;
}
pTokenizer->pModule = p;
if( SQLITE_OK!=p->xOpen(pTokenizer, zInput, nInput, &pCsr) ){
zErr = "error in xOpen()";
goto finish;
}
pCsr->pTokenizer = pTokenizer;
while( SQLITE_OK==p->xNext(pCsr, &zToken, &nToken, &iStart, &iEnd, &iPos) ){
Tcl_ListObjAppendElement(0, pRet, Tcl_NewIntObj(iPos));
Tcl_ListObjAppendElement(0, pRet, Tcl_NewStringObj(zToken, nToken));
zToken = &zInput[iStart];
nToken = iEnd-iStart;
Tcl_ListObjAppendElement(0, pRet, Tcl_NewStringObj(zToken, nToken));
}
if( SQLITE_OK!=p->xClose(pCsr) ){
zErr = "error in xClose()";
goto finish;
}
if( SQLITE_OK!=p->xDestroy(pTokenizer) ){
zErr = "error in xDestroy()";
goto finish;
}
finish:
if( zErr ){
sqlite3_result_error(context, zErr, -1);
}else{
sqlite3_result_text(context, Tcl_GetString(pRet), -1, SQLITE_TRANSIENT);
}
Tcl_DecrRefCount(pRet);
}
void
Tcl_MainEx(
int argc, /* Number of arguments. */
TCHAR **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc,
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
Tcl_Interp *interp)
{
Tcl_Obj *path, *resultPtr, *argvPtr, *appName, *LObj;
int commandLen;
char *commandStr;
const char *encodingName = NULL;
int code, exitCode = 0, isL = 0;
Tcl_MainLoopProc *mainLoopProc;
Tcl_Channel chan;
InteractiveState is;
TclpSetInitialEncodings();
TclpFindExecutable((const char *)argv[0]);
Tcl_InitMemory(interp);
is.interp = interp;
is.prompt = PROMPT_START;
is.commandPtr = Tcl_NewObj();
/*
* If the application has not already set a startup script, parse the
* first few command line arguments to determine the script path and
* encoding.
*/
if (NULL == Tcl_GetStartupScript(NULL)) {
/*
* Check whether initial args (argv[1] and beyond) look like
* -encoding ENCODING FILENAME
* or like
* [-opt1] [-opt2] ... [-optn] FILENAME
*/
/* Create argv list obj for L. */
L->global->tclsh_argc = 1;
L->global->tclsh_argv = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, L->global->tclsh_argv,
NewNativeObj(argv[0], -1));
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2], -1);
Tcl_SetStartupScript(NewNativeObj(argv[3], -1),
Tcl_GetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
argv += 3;
} else if (argc > 1) {
/* Pass over all options to look for a file name. */
int i;
Tcl_Obj *argObj;
for (i = 1; i < argc; ++i) {
argObj = NewNativeObj(argv[i], -1);
Tcl_ListObjAppendElement(NULL, L->global->tclsh_argv, argObj);
++L->global->tclsh_argc;
if ('-' != argv[i][0]) {
Tcl_SetStartupScript(argObj, NULL);
argc -= i;
argv += i;
break;
} else if (!_tcscmp(argv[i], TEXT("--version")) ||
!_tcscmp(argv[i], TEXT("-version"))) {
if (strlen(L_VER_TAG)) {
printf("L version is %s %s for %s\n",
L_VER_TAG, L_VER_UTC, L_VER_PLATFORM);
} else {
printf("L version is %s for %s\n",
L_VER_UTC, L_VER_PLATFORM);
}
printf("Built by: %s\n", L_VER_USER);
printf("Built in: %s\n", L_VER_PWD);
printf("Built on: %s\n", L_VER_BUILD_TIME);
exit(0);
}
}
}
}
path = Tcl_GetStartupScript(&encodingName);
if (path == NULL) {
appName = NewNativeObj(argv[0], -1);
} else {
appName = path;
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
L->global->script_argc = argc;
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1));
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
L->global->script_argv = argvPtr;
Tcl_IncrRefCount(argvPtr);
/*
* Set the "tcl_interactive" variable.
*/
is.tty = isatty(0);
Tcl_SetVar2Ex(interp, "tcl_interactive", NULL,
Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
Tcl_Preserve(interp);
if (appInitProc(interp) != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteChars(chan,
"application-specific initialization failed: ", -1);
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
}
if (Tcl_InterpDeleted(interp)) {
goto done;
}
if (Tcl_LimitExceeded(interp)) {
goto done;
}
if (TclFullFinalizationRequested()) {
/*
* Arrange for final deletion of the main interp
*/
/* ARGH Munchhausen effect */
Tcl_CreateExitHandler(FreeMainInterp, interp);
}
/*
* Invoke the script specified on the command line, if any. Must fetch it
* again, as the appInitProc might have reset it.
*/
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
int argc, i;
char *av0path;
Tcl_Obj **argvObjs, *pathObj;
/*
* Set L->global->forceL if argv[0] is "L", or "-L" or "--L" was given
* as a cmd-line option. This causes Tcl_FSEvalFileEx() to wrap the
* input file in a #lang L regardless of its extension.
*/
if (L->global->tclsh_argv) {
Tcl_ListObjGetElements(interp, L->global->tclsh_argv, &argc,
&argvObjs);
pathObj = Tcl_FSGetNormalizedPath(interp, argvObjs[0]);
av0path = Tcl_GetString(pathObj);
if (av0path) {
L->global->forceL = (!strcmp(av0path+strlen(av0path)-2, "/L"));
}
for (i = 1; i < argc; ++i) {
if (!strcmp(Tcl_GetString(argvObjs[i]), "--L") ||
!strcmp(Tcl_GetString(argvObjs[i]), "-L")) {
L->global->forceL = 1;
}
}
}
Tcl_ResetResult(interp);
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr;
TclNewLiteralStringObj(keyPtr, "-errorinfo");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
Tcl_WriteObj(chan, valuePtr);
}
Tcl_WriteChars(chan, "\n", 1);
Tcl_DecrRefCount(options);
}
exitCode = 1;
}
goto done;
}
/*
* We're running interactively. Source a user-specific startup file if the
* application specified one and if the file exists.
*/
Tcl_SourceRCFile(interp);
if (Tcl_LimitExceeded(interp)) {
goto done;
}
/*
* Process commands from stdin until there's an end-of-file. Note that we
* need to fetch the standard channels again after every eval, since they
* may have been changed.
*/
Tcl_IncrRefCount(is.commandPtr);
/*
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
Tcl_LinkVar(interp, "L", (char *) &isL, TCL_LINK_BOOLEAN);
Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
is.input = Tcl_GetStdChannel(TCL_STDIN);
while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
mainLoopProc = TclGetMainLoop();
if (mainLoopProc == NULL) {
int length;
if (is.tty) {
Prompt(interp, &is);
if (Tcl_InterpDeleted(interp)) {
break;
}
if (Tcl_LimitExceeded(interp)) {
break;
}
is.input = Tcl_GetStdChannel(TCL_STDIN);
if (is.input == NULL) {
break;
}
}
if (Tcl_IsShared(is.commandPtr)) {
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
}
length = Tcl_GetsObj(is.input, is.commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(is.input)) {
/*
* This can only happen if stdin has been set to
* non-blocking. In that case cycle back and try again.
* This sets up a tight polling loop (since we have no
* event loop running). If this causes bad CPU hogging, we
* might try toggling the blocking on stdin instead.
*/
continue;
}
/*
* Either EOF, or an error on stdin; we're done
*/
break;
}
/*
* Check for the #lang comments and sub them out for
* meaningful commands.
*/
commandStr = Tcl_GetStringFromObj(is.commandPtr, &commandLen);
if (!isL && strncasecmp(commandStr, "#lang l", 7) == 0) {
Tcl_SetStringObj(is.commandPtr, "set ::L 1", -1);
} else if (isL && strncasecmp(commandStr, "#lang tcl", 9) == 0) {
Tcl_SetStringObj(is.commandPtr, "set('::L',0);", -1);
}
/*
* Add the newline removed by Tcl_GetsObj back to the string. Have
* to add it back before testing completeness, because it can make
* a difference. [Bug 1775878]
*/
if (Tcl_IsShared(is.commandPtr)) {
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
}
Tcl_AppendToObj(is.commandPtr, "\n", 1);
if (!TclObjCommandComplete(is.commandPtr)) {
is.prompt = PROMPT_CONTINUE;
continue;
}
is.prompt = PROMPT_START;
if (isL) {
LObj = Tcl_NewStringObj("L {", -1);
Tcl_AppendObjToObj(LObj, is.commandPtr);
if (commandStr[commandLen-1] != ';') {
Tcl_AppendToObj(LObj, ";", -1);
}
Tcl_AppendToObj(LObj, "}\n", -1);
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = LObj;
Tcl_IncrRefCount(is.commandPtr);
}
/*
* The final newline is syntactically redundant, and causes some
* error messages troubles deeper in, so lop it back off.
*/
Tcl_GetStringFromObj(is.commandPtr, &length);
Tcl_SetObjLength(is.commandPtr, --length);
code = Tcl_RecordAndEvalObj(interp, is.commandPtr,
TCL_EVAL_GLOBAL);
is.input = Tcl_GetStdChannel(TCL_STDIN);
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(is.commandPtr);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
} else if (is.tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
chan = Tcl_GetStdChannel(TCL_STDOUT);
if ((length > 0) && chan) {
Tcl_WriteObj(chan, resultPtr);
Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
} else { /* (mainLoopProc != NULL) */
/*
* If a main loop has been defined while running interactively, we
* want to start a fileevent based prompt by establishing a
* channel handler for stdin.
*/
if (is.input) {
if (is.tty) {
Prompt(interp, &is);
}
Tcl_CreateChannelHandler(is.input, TCL_READABLE,
StdinProc, &is);
}
mainLoopProc();
Tcl_SetMainLoop(NULL);
if (is.input) {
Tcl_DeleteChannelHandler(is.input, StdinProc, &is);
}
is.input = Tcl_GetStdChannel(TCL_STDIN);
}
/*
* This code here only for the (unsupported and deprecated) [checkmem]
* command.
*/
#ifdef TCL_MEM_DEBUG
if (tclMemDumpFileName != NULL) {
Tcl_SetMainLoop(NULL);
Tcl_DeleteInterp(interp);
}
#endif /* TCL_MEM_DEBUG */
}
done:
mainLoopProc = TclGetMainLoop();
if ((exitCode == 0) && mainLoopProc && !Tcl_LimitExceeded(interp)) {
/*
* If everything has gone OK so far, call the main loop proc, if it
* exists. Packages (like Tk) can set it to start processing events at
* this point.
*/
mainLoopProc();
Tcl_SetMainLoop(NULL);
}
if (is.commandPtr != NULL) {
Tcl_DecrRefCount(is.commandPtr);
}
/*
* Rather than calling exit, invoke the "exit" command so that users can
* replace "exit" with some other command to do additional cleanup on
* exit. The Tcl_EvalObjEx call should never return.
*/
if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) {
Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
Tcl_IncrRefCount(cmd);
Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmd);
}
/*
* If Tcl_EvalObjEx returns, trying to eval [exit], something unusual is
* happening. Maybe interp has been deleted; maybe [exit] was redefined,
* maybe we've blown up because of an exceeded limit. We still want to
* cleanup and exit.
*/
Tcl_Exit(exitCode);
}
static int
TestfindwindowObjCmd(
ClientData clientData, /* Main window for application. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
const TCHAR *title = NULL, *class = NULL;
Tcl_DString titleString, classString;
HWND hwnd = NULL;
int r = TCL_OK;
DWORD myPid;
Tcl_DStringInit(&classString);
Tcl_DStringInit(&titleString);
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "title ?class?");
return TCL_ERROR;
}
title = Tcl_WinUtfToTChar(Tcl_GetString(objv[1]), -1, &titleString);
if (objc == 3) {
class = Tcl_WinUtfToTChar(Tcl_GetString(objv[2]), -1, &classString);
}
if (title[0] == 0)
title = NULL;
#if 0
hwnd = FindWindow(class, title);
#else
/* We want find a window the belongs to us and not some other process */
hwnd = NULL;
myPid = GetCurrentProcessId();
while (1) {
DWORD pid, tid;
hwnd = FindWindowEx(NULL, hwnd, class, title);
if (hwnd == NULL)
break;
tid = GetWindowThreadProcessId(hwnd, &pid);
if (tid == 0) {
/* Window has gone */
hwnd = NULL;
break;
}
if (pid == myPid)
break; /* Found it */
}
#endif
if (hwnd == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("failed to find window: ", -1));
AppendSystemError(interp, GetLastError());
r = TCL_ERROR;
} else {
Tcl_SetObjResult(interp, Tcl_NewLongObj(PTR2INT(hwnd)));
}
Tcl_DStringFree(&titleString);
Tcl_DStringFree(&classString);
return r;
}
Pixmap
Tk_AllocBitmapFromObj(
Tcl_Interp *interp, /* Interp for error results. This may be
* NULL. */
Tk_Window tkwin, /* Need the screen the bitmap is used on.*/
Tcl_Obj *objPtr) /* Object describing bitmap; see manual entry
* for legal syntax of string value. */
{
TkBitmap *bitmapPtr;
if (objPtr->typePtr != &tkBitmapObjType) {
InitBitmapObj(objPtr);
}
bitmapPtr = objPtr->internalRep.twoPtrValue.ptr1;
/*
* If the object currently points to a TkBitmap, see if it's the one we
* want. If so, increment its reference count and return.
*/
if (bitmapPtr != NULL) {
if (bitmapPtr->resourceRefCount == 0) {
/*
* This is a stale reference: it refers to a TkBitmap that's no
* longer in use. Clear the reference.
*/
FreeBitmapObj(objPtr);
bitmapPtr = NULL;
} else if ((Tk_Display(tkwin) == bitmapPtr->display)
&& (Tk_ScreenNumber(tkwin) == bitmapPtr->screenNum)) {
bitmapPtr->resourceRefCount++;
return bitmapPtr->bitmap;
}
}
/*
* The object didn't point to the TkBitmap that we wanted. Search the list
* of TkBitmaps with the same name to see if one of the others is the
* right one.
*/
if (bitmapPtr != NULL) {
TkBitmap *firstBitmapPtr = Tcl_GetHashValue(bitmapPtr->nameHashPtr);
FreeBitmapObj(objPtr);
for (bitmapPtr = firstBitmapPtr; bitmapPtr != NULL;
bitmapPtr = bitmapPtr->nextPtr) {
if ((Tk_Display(tkwin) == bitmapPtr->display) &&
(Tk_ScreenNumber(tkwin) == bitmapPtr->screenNum)) {
bitmapPtr->resourceRefCount++;
bitmapPtr->objRefCount++;
objPtr->internalRep.twoPtrValue.ptr1 = bitmapPtr;
return bitmapPtr->bitmap;
}
}
}
/*
* Still no luck. Call GetBitmap to allocate a new TkBitmap object.
*/
bitmapPtr = GetBitmap(interp, tkwin, Tcl_GetString(objPtr));
objPtr->internalRep.twoPtrValue.ptr1 = bitmapPtr;
if (bitmapPtr == NULL) {
return None;
}
bitmapPtr->objRefCount++;
return bitmapPtr->bitmap;
}
static int
TestobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex, destIndex, i;
const char *index, *subCmd, *string;
const Tcl_ObjType *targetType;
if (objc < 2) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "assign") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(objv[3]);
if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(destIndex, varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[destIndex]);
} else if (strcmp(subCmd, "convert") == 0) {
const char *typeName;
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
typeName = Tcl_GetString(objv[3]);
if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"no type ", typeName, " found", NULL);
return TCL_ERROR;
}
if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
!= TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "duplicate") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(objv[3]);
if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
Tcl_SetObjResult(interp, varPtr[destIndex]);
} else if (strcmp(subCmd, "freeallvars") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
if (varPtr[i] != NULL) {
Tcl_DecrRefCount(varPtr[i]);
varPtr[i] = NULL;
}
}
} else if (strcmp(subCmd, "invalidateStringRep") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_InvalidateStringRep(varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "newobj") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(varIndex, Tcl_NewObj());
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "objtype") == 0) {
const char *typeName;
/*
* Return an object containing the name of the argument's type of
* internal rep. If none exists, return "none".
*/
if (objc != 3) {
goto wrongNumArgs;
}
if (objv[2]->typePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
} else {
typeName = objv[2]->typePtr->name;
Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
}
} else if (strcmp(subCmd, "refcount") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount));
} else if (strcmp(subCmd, "type") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
} else {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
varPtr[varIndex]->typePtr->name, -1);
}
} else if (strcmp(subCmd, "types") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
if (Tcl_AppendAllObjTypes(interp,
Tcl_GetObjResult(interp)) != TCL_OK) {
return TCL_ERROR;
}
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be assign, convert, duplicate, freeallvars, "
"newobj, objcount, objtype, refcount, type, or types", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
Tk_Cursor
Tk_AllocCursorFromObj(
Tcl_Interp *interp, /* Interp for error results. */
Tk_Window tkwin, /* Window in which the cursor will be used.*/
Tcl_Obj *objPtr) /* Object describing cursor; see manual entry
* for description of legal syntax of this
* obj's string rep. */
{
TkCursor *cursorPtr;
if (objPtr->typePtr != &tkCursorObjType) {
InitCursorObj(objPtr);
}
cursorPtr = (TkCursor *) objPtr->internalRep.twoPtrValue.ptr1;
/*
* If the object currently points to a TkCursor, see if it's the one we
* want. If so, increment its reference count and return.
*/
if (cursorPtr != NULL) {
if (cursorPtr->resourceRefCount == 0) {
/*
* This is a stale reference: it refers to a TkCursor that's no
* longer in use. Clear the reference.
*/
FreeCursorObjProc(objPtr);
cursorPtr = NULL;
} else if (Tk_Display(tkwin) == cursorPtr->display) {
cursorPtr->resourceRefCount++;
return cursorPtr->cursor;
}
}
/*
* The object didn't point to the TkCursor that we wanted. Search the list
* of TkCursors with the same name to see if one of the other TkCursors is
* the right one.
*/
if (cursorPtr != NULL) {
TkCursor *firstCursorPtr = (TkCursor *)
Tcl_GetHashValue(cursorPtr->hashPtr);
FreeCursorObjProc(objPtr);
for (cursorPtr = firstCursorPtr; cursorPtr != NULL;
cursorPtr = cursorPtr->nextPtr) {
if (Tk_Display(tkwin) == cursorPtr->display) {
cursorPtr->resourceRefCount++;
cursorPtr->objRefCount++;
objPtr->internalRep.twoPtrValue.ptr1 = (void *) cursorPtr;
return cursorPtr->cursor;
}
}
}
/*
* Still no luck. Call TkcGetCursor to allocate a new TkCursor object.
*/
cursorPtr = TkcGetCursor(interp, tkwin, Tcl_GetString(objPtr));
objPtr->internalRep.twoPtrValue.ptr1 = (void *) cursorPtr;
if (cursorPtr == NULL) {
return None;
}
cursorPtr->objRefCount++;
return cursorPtr->cursor;
}
static int
TestintobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int intValue, varIndex, i;
long longValue;
const char *index, *subCmd, *string;
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "set") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
string = Tcl_GetString(objv[3]);
if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
intValue = i;
/*
* If the object currently bound to the variable with index varIndex
* has ref count 1 (i.e. the object is unshared) we can modify that
* object directly. Otherwise, if RC>1 (i.e. the object is shared), we
* must create a new object to modify/set and decrement the old
* formerly-shared object's ref count. This is "copy on write".
*/
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue);
} else {
SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */
if (objc != 4) {
goto wrongNumArgs;
}
string = Tcl_GetString(objv[3]);
if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
intValue = i;
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue);
} else {
SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
}
} else if (strcmp(subCmd, "setlong") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
string = Tcl_GetString(objv[3]);
if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
intValue = i;
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetLongObj(varPtr[varIndex], intValue);
} else {
SetVarToObj(varIndex, Tcl_NewLongObj(intValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "setmaxlong") == 0) {
long maxLong = LONG_MAX;
if (objc != 3) {
goto wrongNumArgs;
}
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetLongObj(varPtr[varIndex], maxLong);
} else {
SetVarToObj(varIndex, Tcl_NewLongObj(maxLong));
}
} else if (strcmp(subCmd, "ismaxlong") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) {
return TCL_ERROR;
}
Tcl_AppendToObj(Tcl_GetObjResult(interp),
((longValue == LONG_MAX)? "1" : "0"), -1);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "get2") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(varPtr[varIndex]);
Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
} else if (strcmp(subCmd, "inttoobigtest") == 0) {
/*
* If long ints have more bits than ints on this platform, verify that
* Tcl_GetIntFromObj returns an error if the long int held in an
* integer object's internal representation is too large to fit in an
* int.
*/
if (objc != 3) {
goto wrongNumArgs;
}
#if (INT_MAX == LONG_MAX) /* int is same size as long int */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
#else
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetLongObj(varPtr[varIndex], LONG_MAX);
} else {
SetVarToObj(varIndex, Tcl_NewLongObj(LONG_MAX));
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
return TCL_OK;
}
Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1);
#endif
} else if (strcmp(subCmd, "mult10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
&intValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue * 10);
} else {
SetVarToObj(varIndex, Tcl_NewIntObj(intValue * 10));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "div10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
&intValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue / 10);
} else {
SetVarToObj(varIndex, Tcl_NewIntObj(intValue / 10));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, get2, mult10, or div10", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
TestlistobjCmd(
ClientData clientData, /* Not used */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
/* Subcommands supported by this command */
const char* subcommands[] = {
"set",
"get",
"replace"
};
enum listobjCmdIndex {
LISTOBJ_SET,
LISTOBJ_GET,
LISTOBJ_REPLACE
};
const char* index; /* Argument giving the variable number */
int varIndex; /* Variable number converted to binary */
int cmdIndex; /* Ordinal number of the subcommand */
int first; /* First index in the list */
int count; /* Count of elements in a list */
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?");
return TCL_ERROR;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command",
0, &cmdIndex) != TCL_OK) {
return TCL_ERROR;
}
switch(cmdIndex) {
case LISTOBJ_SET:
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3);
} else {
SetVarToObj(varIndex, Tcl_NewListObj(objc-3, objv+3));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case LISTOBJ_GET:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case LISTOBJ_REPLACE:
if (objc < 5) {
Tcl_WrongNumArgs(interp, 2, objv,
"varIndex start count ?element...?");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[4], &count) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
Tcl_ResetResult(interp);
return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count,
objc-5, objv+5);
}
return TCL_OK;
}
static int
TestindexobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int allowAbbrev, index, index2, setError, i, result;
const char **argv;
static const char *const tablePtr[] = {"a", "b", "check", NULL};
/*
* Keep this structure declaration in sync with tclIndexObj.c
*/
struct IndexRep {
void *tablePtr; /* Pointer to the table of strings. */
int offset; /* Offset between table entries. */
int index; /* Selected index into table. */
};
struct IndexRep *indexRep;
if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),
"check") == 0)) {
/*
* This code checks to be sure that the results of Tcl_GetIndexFromObj
* are properly cached in the object and returned on subsequent
* lookups.
*/
if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
return TCL_ERROR;
}
Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr;
indexRep->index = index2;
result = Tcl_GetIndexFromObj(NULL, objv[1],
tablePtr, "token", 0, &index);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
if (objc < 5) {
Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", -1);
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
return TCL_ERROR;
}
argv = (const char **) ckalloc((unsigned) ((objc-3) * sizeof(char *)));
for (i = 4; i < objc; i++) {
argv[i-4] = Tcl_GetString(objv[i]);
}
argv[objc-4] = NULL;
/*
* Tcl_GetIndexFromObj assumes that the table is statically-allocated so
* that its address is different for each index object. If we accidently
* allocate a table at the same address as that cached in the index
* object, clear out the object's cached state.
*/
if (objv[3]->typePtr != NULL
&& !strcmp("index", objv[3]->typePtr->name)) {
indexRep = (struct IndexRep *) objv[3]->internalRep.otherValuePtr;
if (indexRep->tablePtr == (void *) argv) {
objv[3]->typePtr->freeIntRepProc(objv[3]);
objv[3]->typePtr = NULL;
}
}
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);
ckfree((char *) argv);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
static int
TestdoubleobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex;
double doubleValue;
const char *index, *subCmd, *string;
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "set") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
string = Tcl_GetString(objv[3]);
if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) {
return TCL_ERROR;
}
/*
* If the object currently bound to the variable with index varIndex
* has ref count 1 (i.e. the object is unshared) we can modify that
* object directly. Otherwise, if RC>1 (i.e. the object is shared), we
* must create a new object to modify/set and decrement the old
* formerly-shared object's ref count. This is "copy on write".
*/
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetDoubleObj(varPtr[varIndex], doubleValue);
} else {
SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "mult10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
&doubleValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetDoubleObj(varPtr[varIndex], doubleValue * 10.0);
} else {
SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue * 10.0));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "div10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
&doubleValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetDoubleObj(varPtr[varIndex], doubleValue / 10.0);
} else {
SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue / 10.0));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, mult10, or div10", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
TestbignumobjCmd(
ClientData clientData, /* unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
const char *const subcmds[] = {
"set", "get", "mult10", "div10", NULL
};
enum options {
BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10
};
int index, varIndex;
const char *string;
mp_int bignumValue, newValue;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
string = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case BIGNUM_SET:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "var value");
return TCL_ERROR;
}
string = Tcl_GetString(objv[3]);
if (mp_init(&bignumValue) != MP_OKAY) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("error in mp_init", -1));
return TCL_ERROR;
}
if (mp_read_radix(&bignumValue, string, 10) != MP_OKAY) {
mp_clear(&bignumValue);
Tcl_SetObjResult(interp,
Tcl_NewStringObj("error in mp_read_radix", -1));
return TCL_ERROR;
}
/*
* If the object currently bound to the variable with index varIndex
* has ref count 1 (i.e. the object is unshared) we can modify that
* object directly. Otherwise, if RC>1 (i.e. the object is shared),
* we must create a new object to modify/set and decrement the old
* formerly-shared object's ref count. This is "copy on write".
*/
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetBignumObj(varPtr[varIndex], &bignumValue);
} else {
SetVarToObj(varIndex, Tcl_NewBignumObj(&bignumValue));
}
break;
case BIGNUM_GET:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
break;
case BIGNUM_MULT10:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
&bignumValue) != TCL_OK) {
return TCL_ERROR;
}
if (mp_init(&newValue) != MP_OKAY
|| (mp_mul_d(&bignumValue, 10, &newValue) != MP_OKAY)) {
mp_clear(&bignumValue);
mp_clear(&newValue);
Tcl_SetObjResult(interp,
Tcl_NewStringObj("error in mp_mul_d", -1));
return TCL_ERROR;
}
mp_clear(&bignumValue);
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetBignumObj(varPtr[varIndex], &newValue);
} else {
SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue));
}
break;
case BIGNUM_DIV10:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
&bignumValue) != TCL_OK) {
return TCL_ERROR;
}
if (mp_init(&newValue) != MP_OKAY
|| (mp_div_d(&bignumValue, 10, &newValue, NULL) != MP_OKAY)) {
mp_clear(&bignumValue);
mp_clear(&newValue);
Tcl_SetObjResult(interp,
Tcl_NewStringObj("error in mp_div_d", -1));
return TCL_ERROR;
}
mp_clear(&bignumValue);
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetBignumObj(varPtr[varIndex], &newValue);
} else {
SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue));
}
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
return TCL_OK;
}
/* 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;
}
XColor *
Tk_GetColorFromObj(
Tk_Window tkwin, /* The window in which the color will be
* used. */
Tcl_Obj *objPtr) /* String value contains the name of the
* desired color. */
{
TkColor *tkColPtr;
Tcl_HashEntry *hashPtr;
TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr;
if (objPtr->typePtr != &tkColorObjType) {
InitColorObj(objPtr);
}
/*
* First check to see if the internal representation of the object is
* defined and is a color that is valid for the current screen and color
* map. If it is, we are done.
*/
tkColPtr = (TkColor *) objPtr->internalRep.twoPtrValue.ptr1;
if ((tkColPtr != NULL)
&& (tkColPtr->resourceRefCount > 0)
&& (Tk_Screen(tkwin) == tkColPtr->screen)
&& (Tk_Colormap(tkwin) == tkColPtr->colormap)) {
/*
* The object already points to the right TkColor structure. Just
* return it.
*/
return (XColor *) tkColPtr;
}
/*
* If we reach this point, it means that the TkColor structure that we
* have cached in the internal representation is not valid for the current
* screen and colormap. But there is a list of other TkColor structures
* attached to the TkDisplay. Walk this list looking for the right TkColor
* structure.
*/
hashPtr = Tcl_FindHashEntry(&dispPtr->colorNameTable,
Tcl_GetString(objPtr));
if (hashPtr == NULL) {
goto error;
}
for (tkColPtr = (TkColor *) Tcl_GetHashValue(hashPtr);
(tkColPtr != NULL); tkColPtr = tkColPtr->nextPtr) {
if ((Tk_Screen(tkwin) == tkColPtr->screen)
&& (Tk_Colormap(tkwin) == tkColPtr->colormap)) {
FreeColorObjProc(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = (void *) tkColPtr;
tkColPtr->objRefCount++;
return (XColor *) tkColPtr;
}
}
error:
Tcl_Panic("Tk_GetColorFromObj called with non-existent color!");
/*
* The following code isn't reached; it's just there to please compilers.
*/
return NULL;
}
static int
TestwineventObjCmd(
ClientData clientData, /* Main window for application. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
HWND hwnd = 0;
HWND child = 0;
HWND control;
int id;
char *rest;
UINT message;
WPARAM wParam;
LPARAM lParam;
LRESULT result;
static const TkStateMap messageMap[] = {
{WM_LBUTTONDOWN, "WM_LBUTTONDOWN"},
{WM_LBUTTONUP, "WM_LBUTTONUP"},
{WM_CHAR, "WM_CHAR"},
{WM_GETTEXT, "WM_GETTEXT"},
{WM_SETTEXT, "WM_SETTEXT"},
{WM_COMMAND, "WM_COMMAND"},
{-1, NULL}
};
if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]), "debug") == 0)) {
int b;
if (Tcl_GetBoolean(interp, Tcl_GetString(objv[2]), &b) != TCL_OK) {
return TCL_ERROR;
}
TkWinDialogDebug(b);
return TCL_OK;
}
if (objc < 4) {
return TCL_ERROR;
}
hwnd = INT2PTR(strtol(Tcl_GetString(objv[1]), &rest, 0));
if (rest == Tcl_GetString(objv[1])) {
hwnd = FindWindowA(NULL, Tcl_GetString(objv[1]));
if (hwnd == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("no such window", -1));
return TCL_ERROR;
}
}
UpdateWindow(hwnd);
id = strtol(Tcl_GetString(objv[2]), &rest, 0);
if (rest == Tcl_GetString(objv[2])) {
char buf[256];
child = GetWindow(hwnd, GW_CHILD);
while (child != NULL) {
SendMessageA(child, WM_GETTEXT, (WPARAM) sizeof(buf), (LPARAM) buf);
if (strcasecmp(buf, Tcl_GetString(objv[2])) == 0) {
id = GetDlgCtrlID(child);
break;
}
child = GetWindow(child, GW_HWNDNEXT);
}
if (child == NULL) {
Tcl_AppendResult(interp, "could not find a control matching \"",
Tcl_GetString(objv[2]), "\"", NULL);
return TCL_ERROR;
}
}
message = TkFindStateNum(NULL, NULL, messageMap, Tcl_GetString(objv[3]));
wParam = 0;
lParam = 0;
if (objc > 4) {
wParam = strtol(Tcl_GetString(objv[4]), NULL, 0);
}
if (objc > 5) {
lParam = strtol(Tcl_GetString(objv[5]), NULL, 0);
}
switch (message) {
case WM_GETTEXT: {
Tcl_DString ds;
char buf[256];
#if 0
GetDlgItemTextA(hwnd, id, buf, 256);
#else
control = TestFindControl(hwnd, id);
if (control == NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("Could not find control with id %d", id));
return TCL_ERROR;
}
buf[0] = 0;
SendMessageA(control, WM_GETTEXT, (WPARAM)sizeof(buf),
(LPARAM) buf);
#endif
Tcl_ExternalToUtfDString(NULL, buf, -1, &ds);
Tcl_AppendResult(interp, Tcl_DStringValue(&ds), NULL);
Tcl_DStringFree(&ds);
break;
}
case WM_SETTEXT: {
Tcl_DString ds;
control = TestFindControl(hwnd, id);
if (control == NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("Could not find control with id %d", id));
return TCL_ERROR;
}
Tcl_UtfToExternalDString(NULL, Tcl_GetString(objv[4]), -1, &ds);
result = SendMessageA(control, WM_SETTEXT, 0,
(LPARAM) Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
if (result == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("failed to send text to dialog: ", -1));
AppendSystemError(interp, GetLastError());
return TCL_ERROR;
}
break;
}
case WM_COMMAND: {
char buf[TCL_INTEGER_SPACE];
if (objc < 5) {
wParam = MAKEWPARAM(id, 0);
lParam = (LPARAM)child;
}
sprintf(buf, "%d", (int) SendMessageA(hwnd, message, wParam, lParam));
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
break;
}
default: {
char buf[TCL_INTEGER_SPACE];
sprintf(buf, "%d",
(int) SendDlgItemMessageA(hwnd, id, message, wParam, lParam));
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
break;
}
}
return TCL_OK;
}
XColor *
Tk_AllocColorFromObj(
Tcl_Interp *interp, /* Used only for error reporting. If NULL,
* then no messages are provided. */
Tk_Window tkwin, /* Window in which the color will be used.*/
Tcl_Obj *objPtr) /* Object that describes the color; string
* value is a color name such as "red" or
* "#ff0000".*/
{
TkColor *tkColPtr;
if (objPtr->typePtr != &tkColorObjType) {
InitColorObj(objPtr);
}
tkColPtr = (TkColor *) objPtr->internalRep.twoPtrValue.ptr1;
/*
* If the object currently points to a TkColor, see if it's the one we
* want. If so, increment its reference count and return.
*/
if (tkColPtr != NULL) {
if (tkColPtr->resourceRefCount == 0) {
/*
* This is a stale reference: it refers to a TkColor that's no
* longer in use. Clear the reference.
*/
FreeColorObjProc(objPtr);
tkColPtr = NULL;
} else if ((Tk_Screen(tkwin) == tkColPtr->screen)
&& (Tk_Colormap(tkwin) == tkColPtr->colormap)) {
tkColPtr->resourceRefCount++;
return (XColor *) tkColPtr;
}
}
/*
* The object didn't point to the TkColor that we wanted. Search the list
* of TkColors with the same name to see if one of the other TkColors is
* the right one.
*/
if (tkColPtr != NULL) {
TkColor *firstColorPtr = (TkColor *)
Tcl_GetHashValue(tkColPtr->hashPtr);
FreeColorObjProc(objPtr);
for (tkColPtr = firstColorPtr; tkColPtr != NULL;
tkColPtr = tkColPtr->nextPtr) {
if ((Tk_Screen(tkwin) == tkColPtr->screen)
&& (Tk_Colormap(tkwin) == tkColPtr->colormap)) {
tkColPtr->resourceRefCount++;
tkColPtr->objRefCount++;
objPtr->internalRep.twoPtrValue.ptr1 = (void *) tkColPtr;
return (XColor *) tkColPtr;
}
}
}
/*
* Still no luck. Call Tk_GetColor to allocate a new TkColor object.
*/
tkColPtr = (TkColor *) Tk_GetColor(interp, tkwin, Tcl_GetString(objPtr));
objPtr->internalRep.twoPtrValue.ptr1 = (void *) tkColPtr;
if (tkColPtr != NULL) {
tkColPtr->objRefCount++;
}
return (XColor *) tkColPtr;
}
struct stat from_sb, to_sb;
mode_t *set;
u_long fset = 0;
int no_target, rval;
u_int iflags;
char *curdir;
const char *group, *owner, *cp;
Tcl_Obj *to_name;
int dodir = 0;
suffix = BACKUP_SUFFIX;
mode = S_IRWXU | S_IRGRP | S_IXGRP | S_IROTH | S_IXOTH;
safecopy = docompare = dostrip = dobackup = dopreserve = nommap = 0;
iflags = 0;
group = owner = curdir = NULL;
funcname = Tcl_GetString(objv[0]);
/* Adjust arguments */
++objv, --objc;
while (objc && (cp = Tcl_GetString(*objv)) && *cp == '-') {
char ch = *++cp;
if (!strchr("BbCcdfgMmopSsvW", ch))
break;
switch(ch) {
case 'B':
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "-B");
return TCL_ERROR;
}
suffix = Tcl_GetString(*(++objv));
const 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. */
const 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;
RegisteredInterp *riPtr, *prevPtr;
const 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 (result != TCL_OK || interpNamePtr == NULL) {
break;
}
interpName = Tcl_GetString(interpNamePtr);
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(Tcl_DStringValue(&dString) + 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 = ckalloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
riPtr->name = ckalloc(strlen(actualName) + 1);
riPtr->nextPtr = interpListPtr;
interpListPtr = riPtr;
strcpy(riPtr->name, actualName);
/*
* TODO: DeleteProc
*/
Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, riPtr, NULL);
if (Tcl_IsSafe(interp)) {
Tcl_HideCommand(interp, "send", "send");
}
Tcl_DStringFree(&dString);
return riPtr->name;
}
turbine_code turbine_run_string(MPI_Comm comm, const char* script,
int argc, char const *const * argv,
char* output,
Tcl_Interp* interp)
{
bool created_interp = false;
if (interp == NULL)
{
// Create Tcl interpreter:
interp = Tcl_CreateInterp();
Tcl_Init(interp);
created_interp = true;
}
if (comm != MPI_COMM_NULL)
{
// Store communicator pointer in Tcl variable for turbine::init
MPI_Comm* comm_ptr = &comm;
Tcl_Obj* TURBINE_ADLB_COMM =
Tcl_NewStringObj("TURBINE_ADLB_COMM", -1);
Tcl_Obj* adlb_comm_ptr = Tcl_NewLongObj((long) comm_ptr);
Tcl_ObjSetVar2(interp, TURBINE_ADLB_COMM, NULL, adlb_comm_ptr, 0);
}
// Render argc/argv for Tcl
turbine_tcl_set_integer(interp, "argc", argc);
Tcl_Obj* argv_obj = Tcl_NewStringObj("argv", -1);
Tcl_Obj* argv_val_obj;
if (argc > 0)
argv_val_obj = turbine_tcl_list_new(argc, argv);
else
argv_val_obj = Tcl_NewStringObj("", 0);
Tcl_ObjSetVar2(interp, argv_obj, NULL, argv_val_obj, 0);
if (output != NULL)
turbine_tcl_set_wideint(interp, "turbine_run_output",
(ptrdiff_t) output);
// Run the user script
int rc = Tcl_Eval(interp, script);
// Check for errors
if (rc != TCL_OK)
{
Tcl_Obj* error_dict = Tcl_GetReturnOptions(interp, rc);
Tcl_Obj* error_info = Tcl_NewStringObj("-errorinfo", -1);
Tcl_Obj* error_msg;
Tcl_DictObjGet(interp, error_dict, error_info, &error_msg);
char* msg_string = Tcl_GetString(error_msg);
printf("turbine_run(): Tcl error: %s\n", msg_string);
return TURBINE_ERROR_UNKNOWN;
}
if (created_interp)
{
// Clean up
Tcl_DeleteInterp(interp);
}
return TURBINE_SUCCESS;
}
int
Tk_SendObjCmd(
ClientData clientData, /* Used only for deletion */
Tcl_Interp *interp, /* The interp we are sending from */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* The arguments */
{
const char *const sendOptions[] = {"-async", "-displayof", "-", NULL};
char *stringRep, *destName;
/*int async = 0;*/
int i, index, firstArg;
RegisteredInterp *riPtr;
Tcl_Obj *listObjPtr;
int result = TCL_OK;
for (i = 1; i < (objc - 1); ) {
stringRep = Tcl_GetString(objv[i]);
if (stringRep[0] == '-') {
if (Tcl_GetIndexFromObj(interp, objv[i], sendOptions, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (index == 0) {
/*async = 1;*/
i++;
} else if (index == 1) {
i += 2;
} else {
i++;
}
} else {
break;
}
}
if (objc < (i + 2)) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-option value ...? interpName arg ?arg ...?");
return TCL_ERROR;
}
destName = Tcl_GetString(objv[i]);
firstArg = i + 1;
/*
* See if the target interpreter is local. If so, execute the command
* directly without going through the DDE server. The only tricky thing is
* passing the result from the target interpreter to the invoking
* interpreter. Watch out: they could be the same!
*/
for (riPtr = interpListPtr; (riPtr != NULL)
&& (strcmp(destName, riPtr->name)); riPtr = riPtr->nextPtr) {
/*
* Empty loop body.
*/
}
if (riPtr != NULL) {
/*
* This command is to a local interp. No need to go through the
* server.
*/
Tcl_Interp *localInterp;
Tcl_Preserve(riPtr);
localInterp = riPtr->interp;
Tcl_Preserve(localInterp);
if (firstArg == (objc - 1)) {
/*
* This might be one of those cases where the new parser is
* faster.
*/
result = Tcl_EvalObjEx(localInterp, objv[firstArg],
TCL_EVAL_DIRECT);
} else {
listObjPtr = Tcl_NewListObj(0, NULL);
for (i = firstArg; i < objc; i++) {
Tcl_ListObjAppendList(interp, listObjPtr, objv[i]);
}
Tcl_IncrRefCount(listObjPtr);
result = Tcl_EvalObjEx(localInterp, listObjPtr, TCL_EVAL_DIRECT);
Tcl_DecrRefCount(listObjPtr);
}
if (interp != localInterp) {
if (result == TCL_ERROR) {
/* Tcl_Obj *errorObjPtr; */
/*
* An error occurred, so transfer error information from the
* destination interpreter back to our interpreter. Must clear
* interp's result before calling Tcl_AddErrorInfo, since
* Tcl_AddErrorInfo will store the interp's result in
* errorInfo before appending riPtr's $errorInfo; we've
* already got everything we need in riPtr's $errorInfo.
*/
Tcl_ResetResult(interp);
Tcl_AddErrorInfo(interp, Tcl_GetVar2(localInterp,
"errorInfo", NULL, TCL_GLOBAL_ONLY));
/* errorObjPtr = Tcl_GetObjVar2(localInterp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
Tcl_SetObjErrorCode(interp, errorObjPtr); */
}
Tcl_SetObjResult(interp, Tcl_GetObjResult(localInterp));
}
Tcl_Release(riPtr);
Tcl_Release(localInterp);
} else {
/*
* TODO: This is a non-local request. Send the script to the server
* and poll it for a result.
*/
}
return result;
}
int objc,
Tcl_Obj *CONST objv[])
{
Tcl_Obj *list = NULL;
const char *file_num = NULL;
const char *line_str = NULL;
const char *num_lines_str = NULL;
uint32 start_line = 0;
uint32 end_line = 0;
uint32 num_lines = 0;
int fd = -1;
int err = 0;
bail_require(objc == 3 || objc == 4);
line_str = Tcl_GetString(objv[1]);
bail_null(line_str);
start_line = (uint32)atoi(line_str);
num_lines_str = Tcl_GetString(objv[2]);
bail_null(num_lines_str);
num_lines = (uint32)atoi(num_lines_str);
end_line = start_line + num_lines;
if (objc == 3) {
errno = 0;
err = web_get_fuselog_name();
bail_error(err);
fd = open(file_fuselog_path, O_RDONLY);
if (fd < 0 ) {
int
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr)
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
{
ldr_module_t lm;
char *pkg;
char *fileName = Tcl_GetString(pathPtr);
const char *native;
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
native = Tcl_FSGetNativePath(pathPtr);
lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS);
if (lm == LDR_NULL_MODULE) {
/*
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path
*/
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS);
Tcl_DStringFree(&ds);
}
if (lm == LDR_NULL_MODULE) {
Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ",
Tcl_PosixError(interp), NULL);
return TCL_ERROR;
}
*clientDataPtr = NULL;
/*
* My convention is to use a [OSF loader] package name the same as shlib,
* since the idiots never implemented ldr_lookup() and it is otherwise
* impossible to get a package name given a module.
*
* I build loadable modules with a makefile rule like
* ld ... -export $@: -o $@ $(OBJS)
*/
if ((pkg = strrchr(fileName, '/')) == NULL) {
pkg = fileName;
} else {
pkg++;
}
*loadHandle = pkg;
*unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
int
TkTextWindowCmd(
register TkText *textPtr, /* Information about text widget. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. Someone else has already
* parsed this command enough to know that
* objv[1] is "window". */
{
int optionIndex;
static const char *const windOptionStrings[] = {
"cget", "configure", "create", "names", NULL
};
enum windOptions {
WIND_CGET, WIND_CONFIGURE, WIND_CREATE, WIND_NAMES
};
register TkTextSegment *ewPtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], windOptionStrings,
"window option", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum windOptions) optionIndex) {
case WIND_CGET: {
TkTextIndex index;
TkTextSegment *ewPtr;
Tcl_Obj *objPtr;
TkTextEmbWindowClient *client;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 3, objv, "index option");
return TCL_ERROR;
}
if (TkTextGetObjIndex(interp, textPtr, objv[3], &index) != TCL_OK) {
return TCL_ERROR;
}
ewPtr = TkTextIndexToSeg(&index, NULL);
if (ewPtr->typePtr != &tkTextEmbWindowType) {
Tcl_AppendResult(interp, "no embedded window at index \"",
Tcl_GetString(objv[3]), "\"", NULL);
return TCL_ERROR;
}
/*
* Copy over client specific value before querying.
*/
client = EmbWinGetClient(textPtr, ewPtr);
if (client != NULL) {
ewPtr->body.ew.tkwin = client->tkwin;
} else {
ewPtr->body.ew.tkwin = NULL;
}
objPtr = Tk_GetOptionValue(interp, (char *) &ewPtr->body.ew,
ewPtr->body.ew.optionTable, objv[4], textPtr->tkwin);
if (objPtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
}
case WIND_CONFIGURE: {
TkTextIndex index;
TkTextSegment *ewPtr;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 3, objv, "index ?-option value ...?");
return TCL_ERROR;
}
if (TkTextGetObjIndex(interp, textPtr, objv[3], &index) != TCL_OK) {
return TCL_ERROR;
}
ewPtr = TkTextIndexToSeg(&index, NULL);
if (ewPtr->typePtr != &tkTextEmbWindowType) {
Tcl_AppendResult(interp, "no embedded window at index \"",
Tcl_GetString(objv[3]), "\"", NULL);
return TCL_ERROR;
}
if (objc <= 5) {
TkTextEmbWindowClient *client;
Tcl_Obj* objPtr;
/*
* Copy over client specific value before querying.
*/
client = EmbWinGetClient(textPtr, ewPtr);
if (client != NULL) {
ewPtr->body.ew.tkwin = client->tkwin;
} else {
ewPtr->body.ew.tkwin = NULL;
}
objPtr = Tk_GetOptionInfo(interp, (char *) &ewPtr->body.ew,
ewPtr->body.ew.optionTable, (objc == 5) ? objv[4] : NULL,
textPtr->tkwin);
if (objPtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
} else {
TkTextChanged(textPtr->sharedTextPtr, NULL, &index, &index);
/*
* It's probably not true that all window configuration can change
* the line height, so we could be more efficient here and only
* call this when necessary.
*/
TkTextInvalidateLineMetrics(textPtr->sharedTextPtr, NULL,
index.linePtr, 0, TK_TEXT_INVALIDATE_ONLY);
return EmbWinConfigure(textPtr, ewPtr, objc-4, objv+4);
}
}
case WIND_CREATE: {
TkTextIndex index;
int lineIndex;
TkTextEmbWindowClient *client;
int res;
/*
* Add a new window. Find where to put the new window, and mark that
* position for redisplay.
*/
if (objc < 4) {
Tcl_WrongNumArgs(interp, 3, objv, "index ?-option value ...?");
return TCL_ERROR;
}
if (TkTextGetObjIndex(interp, textPtr, objv[3], &index) != TCL_OK) {
return TCL_ERROR;
}
/*
* Don't allow insertions on the last (dummy) line of the text.
*/
lineIndex = TkBTreeLinesTo(textPtr, index.linePtr);
if (lineIndex == TkBTreeNumLines(textPtr->sharedTextPtr->tree,
textPtr)) {
lineIndex--;
TkTextMakeByteIndex(textPtr->sharedTextPtr->tree, textPtr,
lineIndex, 1000000, &index);
}
/*
* Create the new window segment and initialize it.
*/
ewPtr = (TkTextSegment *) ckalloc(EW_SEG_SIZE);
ewPtr->typePtr = &tkTextEmbWindowType;
ewPtr->size = 1;
ewPtr->body.ew.sharedTextPtr = textPtr->sharedTextPtr;
ewPtr->body.ew.linePtr = NULL;
ewPtr->body.ew.tkwin = NULL;
ewPtr->body.ew.create = NULL;
ewPtr->body.ew.align = ALIGN_CENTER;
ewPtr->body.ew.padX = ewPtr->body.ew.padY = 0;
ewPtr->body.ew.stretch = 0;
ewPtr->body.ew.optionTable = Tk_CreateOptionTable(interp, optionSpecs);
client = (TkTextEmbWindowClient *)
ckalloc(sizeof(TkTextEmbWindowClient));
client->next = NULL;
client->textPtr = textPtr;
client->tkwin = NULL;
client->chunkCount = 0;
client->displayed = 0;
client->parent = ewPtr;
ewPtr->body.ew.clients = client;
/*
* Link the segment into the text widget, then configure it (delete it
* again if the configuration fails).
*/
TkTextChanged(textPtr->sharedTextPtr, NULL, &index, &index);
TkBTreeLinkSegment(ewPtr, &index);
res = EmbWinConfigure(textPtr, ewPtr, objc-4, objv+4);
client->tkwin = ewPtr->body.ew.tkwin;
if (res != TCL_OK) {
TkTextIndex index2;
TkTextIndexForwChars(NULL, &index, 1, &index2, COUNT_INDICES);
TkBTreeDeleteIndexRange(textPtr->sharedTextPtr->tree, &index,
&index2);
return TCL_ERROR;
}
TkTextInvalidateLineMetrics(textPtr->sharedTextPtr, NULL,
index.linePtr, 0, TK_TEXT_INVALIDATE_ONLY);
break;
}
case WIND_NAMES: {
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 3, objv, NULL);
return TCL_ERROR;
}
for (hPtr = Tcl_FirstHashEntry(&textPtr->sharedTextPtr->windowTable,
&search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_AppendElement(interp,
Tcl_GetHashKey(&textPtr->sharedTextPtr->markTable, hPtr));
}
break;
}
}
return TCL_OK;
}
/**
\brief Configure the named widget using -option parameter passed either
during the creation of the widget or following a configure command.
**/
static int configure ( Tcl_Interp *interp, GtkButton *button, GnoclOption options[] )
{
if ( options[textIdx].status == GNOCL_STATUS_CHANGED && gnoclConfigButtonText ( interp, button, options[textIdx].val.obj ) != TCL_OK )
{
return TCL_ERROR;
}
if ( options[iconIdx].status == GNOCL_STATUS_CHANGED )
{
GnoclStringType type = gnoclGetStringType ( options[iconIdx].val.obj );
GtkWidget *label = gnoclFindChild ( GTK_WIDGET ( button ), GTK_TYPE_LABEL );
if ( type == GNOCL_STR_EMPTY )
{
/* remove all children apart from label */
GtkWidget *child = gtk_bin_get_child ( GTK_BIN ( button ) );
if ( child && ( child != label ) )
{
gtk_widget_ref ( label );
gtk_container_remove ( GTK_CONTAINER ( button ), child );
gtk_container_add ( GTK_CONTAINER ( button ), label );
gtk_widget_unref ( label );
gtk_widget_show ( label );
}
}
else
{
GtkWidget *image = gnoclFindChild ( GTK_WIDGET ( button ), GTK_TYPE_IMAGE );
if ( label == NULL )
{
gtk_button_set_label ( button, "" );
label = gnoclFindChild ( GTK_WIDGET ( button ), GTK_TYPE_LABEL );
}
else if ( ( type & ( GNOCL_STR_STOCK | GNOCL_STR_FILE ) ) == 0 )
{
Tcl_AppendResult ( interp, "Unknown type for \"",
Tcl_GetString ( options[iconIdx].val.obj ),
"\" must be of type FILE (%/) or STOCK (%#)", NULL );
return TCL_ERROR;
}
if ( image == NULL )
{
/* this should match gtkbutton.c */
GtkWidget *hbox = gtk_hbox_new ( 0, 2 );
GtkWidget *align = gtk_alignment_new ( 0.5, 0.5, 0.0, 0.0 );
image = gtk_image_new( );
gtk_box_pack_start ( GTK_BOX ( hbox ), image, 0, 0, 0 );
gtk_widget_ref ( label );
gtk_container_remove ( GTK_CONTAINER ( button ), label );
gtk_box_pack_end ( GTK_BOX ( hbox ), label, 0, 0, 0 );
gtk_widget_unref ( label );
gtk_container_add ( GTK_CONTAINER ( button ), align );
gtk_container_add ( GTK_CONTAINER ( align ), hbox );
gtk_widget_show_all ( align );
}
if ( type & GNOCL_STR_STOCK )
{
GtkStockItem item;
if ( gnoclGetStockItem ( options[iconIdx].val.obj, interp, &item ) != TCL_OK )
{
return TCL_ERROR;
}
gtk_image_set_from_stock ( GTK_IMAGE ( image ), item.stock_id, GTK_ICON_SIZE_BUTTON );
}
else if ( type & GNOCL_STR_FILE )
{
GdkPixbuf *pix = gnoclPixbufFromObj ( interp, options + iconIdx );
if ( pix == NULL )
{
return TCL_ERROR;
}
gtk_image_set_from_pixbuf ( GTK_IMAGE ( image ), pix );
}
}
}
return TCL_OK;
}
extern void getXYZFromList (LPcmsCIEXYZ XYZ,Tcl_Obj **list) {
XYZ->X=atof(Tcl_GetString(list[0]));
XYZ->Y=atof(Tcl_GetString(list[1]));
XYZ->Z=atof(Tcl_GetString(list[2]));
return;
}
void
Tk_MainEx(
int argc, /* Number of arguments. */
TCHAR **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc,
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
Tcl_Interp *interp)
{
Tcl_Obj *path, *argvPtr, *appName;
const char *encodingName;
int code, nullStdin = 0;
Tcl_Channel chan;
InteractiveState is;
/*
* Ensure that we are getting a compatible version of Tcl. This is really
* only an issue when Tk is loaded dynamically.
*/
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
abort();
}
#if defined(__WIN32__) && !defined(__WIN64__) && !defined(UNICODE) && !defined(STATIC_BUILD)
if (tclStubsPtr->reserved9) {
/* We are running win32 Tk under Cygwin, so let's check
* whether the env("DISPLAY") variable or the -display
* argument is set. If so, we really want to run the
* Tk_MainEx function of libtk8.?.dll, not this one. */
if (Tcl_GetVar2(interp, "env", "DISPLAY", TCL_GLOBAL_ONLY)) {
loadCygwinTk:
if (TkCygwinMainEx(argc, argv, appInitProc, interp)) {
/* Should never reach here. */
return;
}
} else {
int i;
for (i = 1; i < argc; ++i) {
if (!_tcscmp(argv[i], TEXT("-display"))) {
goto loadCygwinTk;
}
}
}
}
#endif
Tcl_InitMemory(interp);
is.interp = interp;
is.gotPartial = 0;
Tcl_Preserve(interp);
#if defined(__WIN32__) && !defined(__CYGWIN__)
Tk_InitConsoleChannels(interp);
#endif
#ifdef MAC_OSX_TK
if (Tcl_GetStartupScript(NULL) == NULL) {
TkMacOSXDefaultStartupScript();
}
#endif
/*
* If the application has not already set a startup script, parse the
* first few command line arguments to determine the script path and
* encoding.
*/
if (NULL == Tcl_GetStartupScript(NULL)) {
size_t length;
/*
* Check whether first 3 args (argv[1] - argv[3]) look like
* -encoding ENCODING FILENAME
* or like
* FILENAME
* or like
* -file FILENAME (ancient history support only)
*/
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& (TEXT('-') != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2], -1);
Tcl_SetStartupScript(NewNativeObj(argv[3], -1), Tcl_GetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
argv += 3;
} else if ((argc > 1) && (TEXT('-') != argv[1][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL);
argc--;
argv++;
} else if ((argc > 2) && (length = _tcslen(argv[1]))
&& (length > 1) && (0 == _tcsncmp(TEXT("-file"), argv[1], length))
&& (TEXT('-') != argv[2][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[2], -1), NULL);
argc -= 2;
argv += 2;
}
}
path = Tcl_GetStartupScript(&encodingName);
if (path == NULL) {
appName = NewNativeObj(argv[0], -1);
} else {
appName = path;
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1));
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
is.tty = isatty(0);
#if defined(MAC_OSX_TK)
/*
* On TkAqua, if we don't have a TTY and stdin is a special character file
* of length 0, (e.g. /dev/null, which is what Finder sets when double
* clicking Wish) then use the GUI console.
*/
if (!is.tty) {
struct stat st;
nullStdin = fstat(0, &st) || (S_ISCHR(st.st_mode) && !st.st_blocks);
}
#endif
Tcl_SetVar2Ex(interp, "tcl_interactive", NULL,
Tcl_NewIntObj(!path && (is.tty || nullStdin)), TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
if (appInitProc(interp) != TCL_OK) {
TkpDisplayWarning(Tcl_GetStringResult(interp),
"application-specific initialization failed");
}
/*
* Invoke the script specified on the command line, if any. Must fetch it
* again, as the appInitProc might have reset it.
*/
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
Tcl_ResetResult(interp);
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
/*
* The following statement guarantees that the errorInfo variable
* is set properly.
*/
Tcl_AddErrorInfo(interp, "");
TkpDisplayWarning(Tcl_GetVar(interp, "errorInfo",
TCL_GLOBAL_ONLY), "Error in startup script");
Tcl_DeleteInterp(interp);
Tcl_Exit(1);
}
is.tty = 0;
} else {
/*
* Evaluate the .rc file, if one has been specified.
*/
Tcl_SourceRCFile(interp);
/*
* Establish a channel handler for stdin.
*/
is.input = Tcl_GetStdChannel(TCL_STDIN);
if (is.input) {
Tcl_CreateChannelHandler(is.input, TCL_READABLE, StdinProc, &is);
}
if (is.tty) {
Prompt(interp, &is);
}
}
chan = Tcl_GetStdChannel(TCL_STDOUT);
if (chan) {
Tcl_Flush(chan);
}
Tcl_DStringInit(&is.command);
Tcl_DStringInit(&is.line);
Tcl_ResetResult(interp);
/*
* Loop infinitely, waiting for commands to execute. When there are no
* windows left, Tk_MainLoop returns and we exit.
*/
Tk_MainLoop();
Tcl_DeleteInterp(interp);
Tcl_Release(interp);
Tcl_SetStartupScript(NULL, NULL);
Tcl_Exit(0);
}
extern void getxyYFromList (LPcmsCIExyY xyY,Tcl_Obj **list) {
xyY->x=atof(Tcl_GetString(list[0]));
xyY->y=atof(Tcl_GetString(list[1]));
xyY->Y=atof(Tcl_GetString(list[2]));
return;
}
/* ARGSUSED */
int
Tk_GrabObjCmd(
ClientData clientData, /* Main window associated with interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int globalGrab;
Tk_Window tkwin;
TkDisplay *dispPtr;
const char *arg;
int index;
TkSizeT len;
static const char *const optionStrings[] = {
"current", "release", "set", "status", NULL
};
static const char *const flagStrings[] = {
"-global", NULL
};
enum options {
GRABCMD_CURRENT, GRABCMD_RELEASE, GRABCMD_SET, GRABCMD_STATUS
};
if (objc < 2) {
/*
* Can't use Tcl_WrongNumArgs here because we want the message to
* read:
* wrong # args: should be "cmd ?-global? window" or "cmd option
* ?arg ...?"
* We can fake it with Tcl_WrongNumArgs if we assume the command name
* is "grab", but if it has been aliased, the message will be
* incorrect.
*/
Tcl_WrongNumArgs(interp, 1, objv, "?-global? window");
Tcl_AppendResult(interp, " or \"", Tcl_GetString(objv[0]),
" option ?arg ...?\"", NULL);
/* This API not exposed:
*
((Interp *) interp)->flags |= INTERP_ALTERNATE_WRONG_ARGS;
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
*/
return TCL_ERROR;
}
/*
* First check for a window name or "-global" as the first argument.
*/
arg = TkGetStringFromObj(objv[1], &len);
if (arg[0] == '.') {
/* [grab window] */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?-global? window");
return TCL_ERROR;
}
tkwin = Tk_NameToWindow(interp, arg, clientData);
if (tkwin == NULL) {
return TCL_ERROR;
}
return Tk_Grab(interp, tkwin, 0);
} else if (arg[0] == '-' && len > 1) {
if (Tcl_GetIndexFromObj(interp, objv[1], flagStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
/* [grab -global window] */
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?-global? window");
return TCL_ERROR;
}
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), clientData);
if (tkwin == NULL) {
return TCL_ERROR;
}
return Tk_Grab(interp, tkwin, 1);
}
/*
* First argument is not a window name and not "-global", find out which
* option it is.
*/
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case GRABCMD_CURRENT:
/* [grab current ?window?] */
if (objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "current ?window?");
return TCL_ERROR;
}
if (objc == 3) {
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]),
clientData);
if (tkwin == NULL) {
return TCL_ERROR;
}
dispPtr = ((TkWindow *) tkwin)->dispPtr;
if (dispPtr->eventualGrabWinPtr != NULL) {
Tcl_SetObjResult(interp, TkNewWindowObj((Tk_Window)
dispPtr->eventualGrabWinPtr));
}
} else {
Tcl_Obj *resultObj = Tcl_NewObj();
for (dispPtr = TkGetDisplayList(); dispPtr != NULL;
dispPtr = dispPtr->nextPtr) {
if (dispPtr->eventualGrabWinPtr != NULL) {
Tcl_ListObjAppendElement(NULL, resultObj, TkNewWindowObj(
(Tk_Window) dispPtr->eventualGrabWinPtr));
}
}
Tcl_SetObjResult(interp, resultObj);
}
return TCL_OK;
case GRABCMD_RELEASE:
/* [grab release window] */
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "release window");
return TCL_ERROR;
}
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), clientData);
if (tkwin == NULL) {
Tcl_ResetResult(interp);
} else {
Tk_Ungrab(tkwin);
}
break;
case GRABCMD_SET:
/* [grab set ?-global? window] */
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "set ?-global? window");
return TCL_ERROR;
}
if (objc == 3) {
globalGrab = 0;
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]),
clientData);
} else {
globalGrab = 1;
/*
* We could just test the argument by hand instead of using
* Tcl_GetIndexFromObj; the benefit of using the function is that
* it sets up the error message for us, so we are certain to be
* consistant with the rest of Tcl.
*/
if (Tcl_GetIndexFromObj(interp, objv[2], flagStrings, "option",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[3]),
clientData);
}
if (tkwin == NULL) {
return TCL_ERROR;
}
return Tk_Grab(interp, tkwin, globalGrab);
case GRABCMD_STATUS: {
/* [grab status window] */
TkWindow *winPtr;
const char *statusString;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "status window");
return TCL_ERROR;
}
winPtr = (TkWindow *) Tk_NameToWindow(interp, Tcl_GetString(objv[2]),
clientData);
if (winPtr == NULL) {
return TCL_ERROR;
}
dispPtr = winPtr->dispPtr;
if (dispPtr->eventualGrabWinPtr != winPtr) {
statusString = "none";
} else if (dispPtr->grabFlags & GRAB_GLOBAL) {
statusString = "global";
} else {
statusString = "local";
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(statusString, -1));
break;
}
}
return TCL_OK;
}