void
TclReleaseLiteral(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
register Tcl_Obj *objPtr) /* Points to a literal object that was
* previously created by a call to
* TclRegisterLiteral. */
{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr = &(iPtr->literalTable);
register LiteralEntry *entryPtr, *prevPtr;
char *bytes;
int length, index;
bytes = TclGetStringFromObj(objPtr, &length);
index = (HashString(bytes, length) & globalTablePtr->mask);
/*
* Check to see if the object is in the global literal table and remove
* this reference. The object may not be in the table if it is a hidden
* local literal.
*/
for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index];
entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) {
if (entryPtr->objPtr == objPtr) {
entryPtr->refCount--;
/*
* If the literal is no longer being used by any ByteCode, delete
* the entry then remove the reference corresponding to the global
* literal table entry (decrement the ref count of the object).
*/
if (entryPtr->refCount == 0) {
if (prevPtr == NULL) {
globalTablePtr->buckets[index] = entryPtr->nextPtr;
} else {
prevPtr->nextPtr = entryPtr->nextPtr;
}
ckfree((char *) entryPtr);
globalTablePtr->numEntries--;
TclDecrRefCount(objPtr);
#ifdef TCL_COMPILE_STATS
iPtr->stats.currentLitStringBytes -= (double) (length + 1);
#endif /*TCL_COMPILE_STATS*/
}
break;
}
}
/*
* Remove the reference corresponding to the local literal table entry.
*/
Tcl_DecrRefCount(objPtr);
}
static void
RebuildLiteralTable(
register LiteralTable *tablePtr)
/* Local or global table to enlarge. */
{
LiteralEntry **oldBuckets;
register LiteralEntry **oldChainPtr, **newChainPtr;
register LiteralEntry *entryPtr;
LiteralEntry **bucketPtr;
char *bytes;
int oldSize, count, index, length;
oldSize = tablePtr->numBuckets;
oldBuckets = tablePtr->buckets;
/*
* Allocate and initialize the new bucket array, and set up hashing
* constants for new array size.
*/
tablePtr->numBuckets *= 4;
tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned)
(tablePtr->numBuckets * sizeof(LiteralEntry *)));
for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets;
count>0 ; count--, newChainPtr++) {
*newChainPtr = NULL;
}
tablePtr->rebuildSize *= 4;
tablePtr->mask = (tablePtr->mask << 2) + 3;
/*
* Rehash all of the existing entries into the new bucket array.
*/
for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) {
for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) {
bytes = TclGetStringFromObj(entryPtr->objPtr, &length);
index = (HashString(bytes, length) & tablePtr->mask);
*oldChainPtr = entryPtr->nextPtr;
bucketPtr = &(tablePtr->buckets[index]);
entryPtr->nextPtr = *bucketPtr;
*bucketPtr = entryPtr;
}
}
/*
* Free up the old bucket array, if it was dynamically allocated.
*/
if (oldBuckets != tablePtr->staticBuckets) {
ckfree((char *) oldBuckets);
}
}
ClientData
TclNativeCreateNativeRep(
Tcl_Obj *pathPtr)
{
char *nativePathPtr;
const char *str;
Tcl_DString ds;
Tcl_Obj *validPathPtr;
int len;
if (TclFSCwdIsNative()) {
/*
* The cwd is native, which means we can use the translated path
* without worrying about normalization (this will also usually be
* shorter so the utf-to-external conversion will be somewhat faster).
*/
validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
} else {
/*
* Make sure the normalized path is set.
*/
validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
Tcl_IncrRefCount(validPathPtr);
}
str = TclGetStringFromObj(validPathPtr, &len);
Tcl_UtfToExternalDString(NULL, str, len, &ds);
len = Tcl_DStringLength(&ds) + sizeof(char);
if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) {
/* See bug [3118489]: NUL in filenames */
Tcl_DecrRefCount(validPathPtr);
Tcl_DStringFree(&ds);
return NULL;
}
Tcl_DecrRefCount(validPathPtr);
nativePathPtr = ckalloc(len);
memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len);
Tcl_DStringFree(&ds);
return nativePathPtr;
}
/* ARGSUSED */
int
Tcl_CloseObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to close. */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
/*
* If there is an error message and it ends with a newline, remove the
* newline. This is done for command pipeline channels where the error
* output from the subprocesses is stored in interp's result.
*
* NOTE: This is likely to not have any effect on regular error
* messages produced by drivers during the closing of a channel,
* because the Tcl convention is that such error messages do not have
* a terminating newline.
*/
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
char *string;
int len;
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
}
string = TclGetStringFromObj(resultPtr, &len);
if ((len > 0) && (string[len - 1] == '\n')) {
Tcl_SetObjLength(resultPtr, len - 1);
}
return TCL_ERROR;
}
return TCL_OK;
}
Tcl_RegExp
Tcl_GetRegExpFromObj(
Tcl_Interp *interp, /* For use in error reporting, and to access
* the interp regexp cache. */
Tcl_Obj *objPtr, /* Object whose string rep contains regular
* expression pattern. Internal rep will be
* changed to compiled form of this regular
* expression. */
int flags) /* Regular expression compilation flags. */
{
int length;
TclRegexp *regexpPtr;
const char *pattern;
/*
* This is OK because we only actually interpret this value properly as a
* TclRegexp* when the type is tclRegexpType.
*/
regexpPtr = objPtr->internalRep.otherValuePtr;
if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
pattern = TclGetStringFromObj(objPtr, &length);
regexpPtr = CompileRegexp(interp, pattern, length, flags);
if (regexpPtr == NULL) {
return NULL;
}
/*
* Add a reference to the regexp so it will persist even if it is
* pushed out of the current thread's regexp cache. This reference
* will be removed when the object's internal rep is freed.
*/
regexpPtr->refCount++;
/*
* Free the old representation and set our type.
*/
TclFreeIntRep(objPtr);
objPtr->internalRep.otherValuePtr = regexpPtr;
objPtr->typePtr = &tclRegexpType;
}
return (Tcl_RegExp) regexpPtr;
}
void
TclHideLiteral(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
register CompileEnv *envPtr,/* Points to CompileEnv whose literal array
* contains the entry being hidden. */
int index) /* The index of the entry in the literal
* array. */
{
LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
LiteralTable *localTablePtr = &(envPtr->localLitTable);
int localHash, length;
char *bytes;
Tcl_Obj *newObjPtr;
lPtr = &(envPtr->literalArrayPtr[index]);
/*
* To avoid unwanted sharing we need to copy the object and remove it from
* the local and global literal tables. It still has a slot in the literal
* array so it can be referred to by byte codes, but it will not be
* matched by literal searches.
*/
newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
Tcl_IncrRefCount(newObjPtr);
TclReleaseLiteral(interp, lPtr->objPtr);
lPtr->objPtr = newObjPtr;
bytes = TclGetStringFromObj(newObjPtr, &length);
localHash = (HashString(bytes, length) & localTablePtr->mask);
nextPtrPtr = &localTablePtr->buckets[localHash];
for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) {
if (entryPtr == lPtr) {
*nextPtrPtr = lPtr->nextPtr;
lPtr->nextPtr = NULL;
localTablePtr->numEntries--;
break;
}
nextPtrPtr = &entryPtr->nextPtr;
}
}
LiteralEntry *
TclLookupLiteralEntry(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
register Tcl_Obj *objPtr) /* Points to a Tcl object holding a literal
* that was previously created by a call to
* TclRegisterLiteral. */
{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr = &(iPtr->literalTable);
register LiteralEntry *entryPtr;
char *bytes;
int length, globalHash;
bytes = TclGetStringFromObj(objPtr, &length);
globalHash = (HashString(bytes, length) & globalTablePtr->mask);
for (entryPtr=globalTablePtr->buckets[globalHash] ; entryPtr!=NULL;
entryPtr=entryPtr->nextPtr) {
if (entryPtr->objPtr == objPtr) {
return entryPtr;
}
}
return NULL;
}
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;
}
void
Tcl_WrongNumArgs(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments to print from objv. */
Tcl_Obj *const objv[], /* Initial argument objects, which should be
* included in the error message. */
const char *message) /* Error message to print after the leading
* objects in objv. The message may be
* NULL. */
{
Tcl_Obj *objPtr;
int i, len, elemLen, flags;
Interp *iPtr = (Interp *) interp;
const char *elementStr;
/*
* [incr Tcl] does something fairly horrific when generating error
* messages for its ensembles; it passes the whole set of ensemble
* arguments as a list in the first argument. This means that this code
* causes a problem in iTcl if it attempts to correctly quote all
* arguments, which would be the correct thing to do. We work around this
* nasty behaviour for now, and hope that we can remove it all in the
* future...
*/
#ifndef AVOID_HACKS_FOR_ITCL
int isFirst = 1; /* Special flag used to inhibit the treating
* of the first word as a list element so the
* hacky way Itcl generates error messages for
* its ensembles will still work. [Bug
* 1066837] */
# define MAY_QUOTE_WORD (!isFirst)
# define AFTER_FIRST_WORD (isFirst = 0)
#else /* !AVOID_HACKS_FOR_ITCL */
# define MAY_QUOTE_WORD 1
# define AFTER_FIRST_WORD (void) 0
#endif /* AVOID_HACKS_FOR_ITCL */
TclNewObj(objPtr);
if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) {
Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp));
Tcl_AppendToObj(objPtr, " or \"", -1);
} else {
Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
}
/*
* Check to see if we are processing an ensemble implementation, and if so
* rewrite the results in terms of how the ensemble was invoked.
*/
if (iPtr->ensembleRewrite.sourceObjs != NULL) {
int toSkip = iPtr->ensembleRewrite.numInsertedObjs;
int toPrint = iPtr->ensembleRewrite.numRemovedObjs;
Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs;
/*
* We only know how to do rewriting if all the replaced objects are
* actually arguments (in objv) to this function. Otherwise it just
* gets too complicated and we'd be better off just giving a slightly
* confusing error message...
*/
if (objc < toSkip) {
goto addNormalArgumentsToMessage;
}
/*
* Strip out the actual arguments that the ensemble inserted.
*/
objv += toSkip;
objc -= toSkip;
/*
* We assume no object is of index type.
*/
for (i=0 ; i<toPrint ; i++) {
/*
* Add the element, quoting it if necessary.
*/
if (origObjv[i]->typePtr == &indexType) {
register IndexRep *indexRep =
origObjv[i]->internalRep.twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
} else if (origObjv[i]->typePtr == &tclEnsembleCmdType) {
register EnsembleCmdRep *ecrPtr =
origObjv[i]->internalRep.twoPtrValue.ptr1;
elementStr = ecrPtr->fullSubcmdName;
elemLen = strlen(elementStr);
} else {
elementStr = TclGetStringFromObj(origObjv[i], &elemLen);
}
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
if (MAY_QUOTE_WORD && len != elemLen) {
char *quotedElementStr = TclStackAlloc(interp,
(unsigned)len + 1);
len = TclConvertElement(elementStr, elemLen,
quotedElementStr, flags);
Tcl_AppendToObj(objPtr, quotedElementStr, len);
TclStackFree(interp, quotedElementStr);
} else {
Tcl_AppendToObj(objPtr, elementStr, elemLen);
}
AFTER_FIRST_WORD;
/*
* Add a space if the word is not the last one (which has a
* moderately complex condition here).
*/
if (i<toPrint-1 || objc!=0 || message!=NULL) {
Tcl_AppendStringsToObj(objPtr, " ", NULL);
}
}
}
/*
* Now add the arguments (other than those rewritten) that the caller took
* from its calling context.
*/
addNormalArgumentsToMessage:
for (i = 0; i < objc; i++) {
/*
* If the object is an index type use the index table which allows for
* the correct error message even if the subcommand was abbreviated.
* Otherwise, just use the string rep.
*/
if (objv[i]->typePtr == &indexType) {
register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
} else if (objv[i]->typePtr == &tclEnsembleCmdType) {
register EnsembleCmdRep *ecrPtr =
objv[i]->internalRep.twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL);
} else {
/*
* Quote the argument if it contains spaces (Bug 942757).
*/
elementStr = TclGetStringFromObj(objv[i], &elemLen);
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
if (MAY_QUOTE_WORD && len != elemLen) {
char *quotedElementStr = TclStackAlloc(interp,
(unsigned) len + 1);
len = TclConvertElement(elementStr, elemLen,
quotedElementStr, flags);
Tcl_AppendToObj(objPtr, quotedElementStr, len);
TclStackFree(interp, quotedElementStr);
} else {
Tcl_AppendToObj(objPtr, elementStr, elemLen);
}
}
AFTER_FIRST_WORD;
/*
* Append a space character (" ") if there is more text to follow
* (either another element from objv, or the message string).
*/
if (i<objc-1 || message!=NULL) {
Tcl_AppendStringsToObj(objPtr, " ", NULL);
}
}
/*
* Add any trailing message bits and set the resulting string as the
* interpreter result. Caller is responsible for reporting this as an
* actual error.
*/
if (message != NULL) {
Tcl_AppendStringsToObj(objPtr, message, NULL);
}
Tcl_AppendStringsToObj(objPtr, "\"", NULL);
Tcl_SetObjResult(interp, objPtr);
#undef MAY_QUOTE_WORD
#undef AFTER_FIRST_WORD
}
/* ARGSUSED */
int
Tcl_ExecObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/*
* This function generates an argv array for the string arguments. It
* starts out with stack-allocated space but uses dynamically-allocated
* storage if needed.
*/
Tcl_Obj *resultPtr;
const char **argv;
char *string;
Tcl_Channel chan;
int argc, background, i, index, keepNewline, result, skip, length;
int ignoreStderr;
static const char *options[] = {
"-ignorestderr", "-keepnewline", "--", NULL
};
enum options {
EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST
};
/*
* Check for any leading option arguments.
*/
keepNewline = 0;
ignoreStderr = 0;
for (skip = 1; skip < objc; skip++) {
string = TclGetString(objv[skip]);
if (string[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index == EXEC_KEEPNEWLINE) {
keepNewline = 1;
} else if (index == EXEC_IGNORESTDERR) {
ignoreStderr = 1;
} else {
skip++;
break;
}
}
if (objc <= skip) {
Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?");
return TCL_ERROR;
}
/*
* See if the command is to be run in background.
*/
background = 0;
string = TclGetString(objv[objc - 1]);
if ((string[0] == '&') && (string[1] == '\0')) {
objc--;
background = 1;
}
/*
* Create the string argument array "argv". Make sure argv is large enough
* to hold the argc arguments plus 1 extra for the zero end-of-argv word.
*/
argc = objc - skip;
argv = (const char **)
TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *));
/*
* Copy the string conversions of each (post option) object into the
* argument vector.
*/
for (i = 0; i < argc; i++) {
argv[i] = TclGetString(objv[i + skip]);
}
argv[argc] = NULL;
chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 :
(ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR)));
/*
* Free the argv array.
*/
TclStackFree(interp, (void *)argv);
if (chan == NULL) {
return TCL_ERROR;
}
if (background) {
/*
* Store the list of PIDs from the pipeline in interp's result and
* detach the PIDs (instead of waiting for them).
*/
TclGetAndDetachPids(interp, chan);
if (Tcl_Close(interp, chan) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
resultPtr = Tcl_NewObj();
if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area
* and put them into the regular interpreter result. Fall back to
* the regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "error reading output from command: ",
Tcl_PosixError(interp), NULL);
Tcl_DecrRefCount(resultPtr);
}
return TCL_ERROR;
}
}
/*
* If the process produced anything on stderr, it will have been returned
* in the interpreter result. It needs to be appended to the result
* string.
*/
result = Tcl_Close(interp, chan);
Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp));
/*
* If the last character of the result is a newline, then remove the
* newline character.
*/
if (keepNewline == 0) {
string = TclGetStringFromObj(resultPtr, &length);
if ((length > 0) && (string[length - 1] == '\n')) {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
return result;
}
/* ARGSUSED */
int
Tcl_ReadObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to read from. */
int newline, i; /* Discard newline at end? */
int toRead; /* How many bytes to read? */
int charactersRead; /* How many characters were read? */
int mode; /* Mode in which channel is opened. */
Tcl_Obj *resultPtr, *chanObjPtr;
if ((objc != 2) && (objc != 3)) {
Interp *iPtr;
argerror:
iPtr = (Interp *) interp;
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?");
/*
* Do not append directly; that makes ensembles using this command as
* a subcommand produce the wrong message.
*/
iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId");
iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS;
return TCL_ERROR;
}
i = 1;
newline = 0;
if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
newline = 1;
i++;
}
if (i == objc) {
goto argerror;
}
chanObjPtr = objv[i];
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr),
"\" wasn't opened for reading", NULL);
return TCL_ERROR;
}
i++; /* Consumed channel name. */
/*
* Compute how many bytes to read, and see whether the final newline
* should be dropped.
*/
toRead = -1;
if (i < objc) {
char *arg;
arg = TclGetString(objv[i]);
if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */
if (TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
return TCL_ERROR;
}
} else if (strcmp(arg, "nonewline") == 0) {
newline = 1;
} else {
Tcl_AppendResult(interp, "bad argument \"", arg,
"\": should be \"nonewline\"", NULL);
return TCL_ERROR;
}
}
resultPtr = Tcl_NewObj();
Tcl_IncrRefCount(resultPtr);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
if (charactersRead < 0) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and
* put them into the regular interpreter result. Fall back to the
* regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "error reading \"",
TclGetString(chanObjPtr), "\": ",
Tcl_PosixError(interp), NULL);
}
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
/*
* If requested, remove the last newline in the channel if at EOF.
*/
if ((charactersRead > 0) && (newline != 0)) {
char *result;
int length;
result = TclGetStringFromObj(resultPtr, &length);
if (result[length - 1] == '\n') {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
Tcl_DecrRefCount(resultPtr);
return TCL_OK;
}
/* ARGSUSED */
static void
StdinProc(
ClientData clientData, /* The state of interactive cmd line */
int mask) /* Not used. */
{
int code, length;
InteractiveState *isPtr = clientData;
Tcl_Channel chan = isPtr->input;
Tcl_Obj *commandPtr = isPtr->commandPtr;
Tcl_Interp *interp = isPtr->interp;
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
length = Tcl_GetsObj(chan, commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(chan)) {
return;
}
if (isPtr->tty) {
/*
* Would be better to find a way to exit the mainLoop? Or perhaps
* evaluate [exit]? Leaving as is for now due to compatibility
* concerns.
*/
Tcl_Exit(0);
}
Tcl_DeleteChannelHandler(chan, StdinProc, isPtr);
return;
}
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
isPtr->prompt = PROMPT_CONTINUE;
goto prompt;
}
isPtr->prompt = PROMPT_START;
TclGetStringFromObj(commandPtr, &length);
Tcl_SetObjLength(commandPtr, --length);
/*
* Disable the stdin channel handler while evaluating the command;
* otherwise if the command re-enters the event loop we might process
* commands from stdin before the current command is finished. Among other
* things, this will trash the text of the command being evaluated.
*/
Tcl_CreateChannelHandler(chan, 0, StdinProc, isPtr);
code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN);
Tcl_DecrRefCount(commandPtr);
isPtr->commandPtr = commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
if (chan != NULL) {
Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, isPtr);
}
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan != NULL) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
} else if (isPtr->tty) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
chan = Tcl_GetStdChannel(TCL_STDOUT);
Tcl_IncrRefCount(resultPtr);
TclGetStringFromObj(resultPtr, &length);
if ((length > 0) && (chan != NULL)) {
Tcl_WriteObj(chan, resultPtr);
Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
/*
* If a tty stdin is still around, output a prompt.
*/
prompt:
if (isPtr->tty && (isPtr->input != NULL)) {
Prompt(interp, isPtr);
isPtr->input = Tcl_GetStdChannel(TCL_STDIN);
}
}
int
TclFileTemporaryCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *nameVarObj = NULL; /* Variable to store the name of the temporary
* file in. */
Tcl_Obj *nameObj = NULL; /* Object that will contain the filename. */
Tcl_Channel chan; /* The channel opened (RDWR) on the temporary
* file, or NULL if there's an error. */
Tcl_Obj *tempDirObj = NULL, *tempBaseObj = NULL, *tempExtObj = NULL;
/* Pieces of template. Each piece is NULL if
* it is omitted. The platform temporary file
* engine might ignore some pieces. */
if (objc < 1 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?nameVar? ?template?");
return TCL_ERROR;
}
if (objc > 1) {
nameVarObj = objv[1];
TclNewObj(nameObj);
}
if (objc > 2) {
int length;
Tcl_Obj *templateObj = objv[2];
const char *string = TclGetStringFromObj(templateObj, &length);
/*
* Treat an empty string as if it wasn't there.
*/
if (length == 0) {
goto makeTemporary;
}
/*
* The template only gives a directory if there is a directory
* separator in it.
*/
if (strchr(string, '/') != NULL
|| (tclPlatform == TCL_PLATFORM_WINDOWS
&& strchr(string, '\\') != NULL)) {
tempDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME);
/*
* Only allow creation of temporary files in the native filesystem
* since they are frequently used for integration with external
* tools or system libraries. [Bug 2388866]
*/
if (tempDirObj != NULL && Tcl_FSGetFileSystemForPath(tempDirObj)
!= &tclNativeFilesystem) {
TclDecrRefCount(tempDirObj);
tempDirObj = NULL;
}
}
/*
* The template only gives the filename if the last character isn't a
* directory separator.
*/
if (string[length-1] != '/' && (tclPlatform != TCL_PLATFORM_WINDOWS
|| string[length-1] != '\\')) {
Tcl_Obj *tailObj = TclPathPart(interp, templateObj,
TCL_PATH_TAIL);
if (tailObj != NULL) {
tempBaseObj = TclPathPart(interp, tailObj, TCL_PATH_ROOT);
tempExtObj = TclPathPart(interp, tailObj, TCL_PATH_EXTENSION);
TclDecrRefCount(tailObj);
}
}
}
/*
* Convert empty parts of the template into unspecified parts.
*/
if (tempDirObj && !TclGetString(tempDirObj)[0]) {
TclDecrRefCount(tempDirObj);
tempDirObj = NULL;
}
if (tempBaseObj && !TclGetString(tempBaseObj)[0]) {
TclDecrRefCount(tempBaseObj);
tempBaseObj = NULL;
}
if (tempExtObj && !TclGetString(tempExtObj)[0]) {
TclDecrRefCount(tempExtObj);
tempExtObj = NULL;
}
/*
* Create and open the temporary file.
*/
makeTemporary:
chan = TclpOpenTemporaryFile(tempDirObj,tempBaseObj,tempExtObj, nameObj);
/*
* If we created pieces of template, get rid of them now.
*/
if (tempDirObj) {
TclDecrRefCount(tempDirObj);
}
if (tempBaseObj) {
TclDecrRefCount(tempBaseObj);
}
if (tempExtObj) {
TclDecrRefCount(tempExtObj);
}
/*
* Deal with results.
*/
if (chan == NULL) {
if (nameVarObj) {
TclDecrRefCount(nameObj);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create temporary file: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
if (nameVarObj != NULL) {
if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_UnregisterChannel(interp, chan);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return TCL_OK;
}
Tcl_Obj *
TclpObjLink(
Tcl_Obj *pathPtr,
Tcl_Obj *toPtr,
int linkAction)
{
if (toPtr != NULL) {
const char *src = Tcl_FSGetNativePath(pathPtr);
const char *target = NULL;
if (src == NULL) {
return NULL;
}
/*
* If we're making a symbolic link and the path is relative, then we
* must check whether it exists _relative_ to the directory in which
* the src is found (not relative to the current cwd which is just not
* relevant in this case).
*
* If we're making a hard link, then a relative path is just converted
* to absolute relative to the cwd.
*/
if ((linkAction & TCL_CREATE_SYMBOLIC_LINK)
&& (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) {
Tcl_Obj *dirPtr, *absPtr;
dirPtr = TclPathPart(NULL, pathPtr, TCL_PATH_DIRNAME);
if (dirPtr == NULL) {
return NULL;
}
absPtr = Tcl_FSJoinToPath(dirPtr, 1, &toPtr);
Tcl_IncrRefCount(absPtr);
if (Tcl_FSAccess(absPtr, F_OK) == -1) {
Tcl_DecrRefCount(absPtr);
Tcl_DecrRefCount(dirPtr);
/*
* Target doesn't exist.
*/
errno = ENOENT;
return NULL;
}
/*
* Target exists; we'll construct the relative path we want below.
*/
Tcl_DecrRefCount(absPtr);
Tcl_DecrRefCount(dirPtr);
} else {
target = Tcl_FSGetNativePath(toPtr);
if (target == NULL) {
return NULL;
}
if (access(target, F_OK) == -1) {
/*
* Target doesn't exist.
*/
errno = ENOENT;
return NULL;
}
}
if (access(src, F_OK) != -1) {
/*
* Src exists.
*/
errno = EEXIST;
return NULL;
}
/*
* Check symbolic link flag first, since we prefer to create these.
*/
if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
int targetLen;
Tcl_DString ds;
Tcl_Obj *transPtr;
/*
* Now we don't want to link to the absolute, normalized path.
* Relative links are quite acceptable (but links to ~user are not
* -- these must be expanded first).
*/
transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
if (transPtr == NULL) {
return NULL;
}
target = TclGetStringFromObj(transPtr, &targetLen);
target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds);
Tcl_DecrRefCount(transPtr);
if (symlink(target, src) != 0) {
toPtr = NULL;
}
Tcl_DStringFree(&ds);
} else if (linkAction & TCL_CREATE_HARD_LINK) {
if (link(target, src) != 0) {
return NULL;
}
} else {
errno = ENODEV;
return NULL;
}
return toPtr;
} else {
Tcl_Obj *linkPtr = NULL;
char link[MAXPATHLEN];
int length;
Tcl_DString ds;
Tcl_Obj *transPtr;
transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL) {
return NULL;
}
Tcl_DecrRefCount(transPtr);
length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
if (length < 0) {
return NULL;
}
Tcl_ExternalToUtfDString(NULL, link, length, &ds);
linkPtr = TclDStringToObj(&ds);
Tcl_IncrRefCount(linkPtr);
return linkPtr;
}
}
/* ARGSUSED */
int
Tcl_PutsObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to puts on. */
Tcl_Obj *string; /* String to write. */
Tcl_Obj *chanObjPtr = NULL; /* channel object. */
int newline; /* Add a newline at end? */
int result; /* Result of puts operation. */
int mode; /* Mode in which channel is opened. */
ThreadSpecificData *tsdPtr;
switch (objc) {
case 2: /* [puts $x] */
string = objv[1];
newline = 1;
break;
case 3: /* [puts -nonewline $x] or [puts $chan $x] */
if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
newline = 0;
} else {
newline = 1;
chanObjPtr = objv[1];
}
string = objv[2];
break;
case 4: /* [puts -nonewline $chan $x] or [puts $chan $x nonewline] */
if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
chanObjPtr = objv[2];
string = objv[3];
} else {
/*
* The code below provides backwards compatibility with an old
* form of the command that is no longer recommended or
* documented.
*/
char *arg;
int length;
arg = TclGetStringFromObj(objv[3], &length);
if ((length != 9)
|| (strncmp(arg, "nonewline", (size_t) length) != 0)) {
Tcl_AppendResult(interp, "bad argument \"", arg,
"\": should be \"nonewline\"", NULL);
return TCL_ERROR;
}
chanObjPtr = objv[1];
string = objv[2];
}
newline = 0;
break;
default:
/* [puts] or [puts some bad number of arguments...] */
Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
return TCL_ERROR;
}
if (chanObjPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->initialized) {
tsdPtr->initialized = 1;
TclNewLiteralStringObj(tsdPtr->stdoutObjPtr, "stdout");
Tcl_IncrRefCount(tsdPtr->stdoutObjPtr);
Tcl_CreateThreadExitHandler(FinalizeIOCmdTSD, NULL);
}
chanObjPtr = tsdPtr->stdoutObjPtr;
}
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if ((mode & TCL_WRITABLE) == 0) {
Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr),
"\" wasn't opened for writing", NULL);
return TCL_ERROR;
}
result = Tcl_WriteObj(chan, string);
if (result < 0) {
goto error;
}
if (newline != 0) {
result = Tcl_WriteChars(chan, "\n", 1);
if (result < 0) {
goto error;
}
}
return TCL_OK;
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and put
* them into the regular interpreter result. Fall back to the regular
* message if nothing was found in the bypass.
*/
error:
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_AppendResult(interp, "error writing \"",
TclGetString(chanObjPtr), "\": ",
Tcl_PosixError(interp), NULL);
}
return TCL_ERROR;
}
/* ARGSUSED */
int
Tcl_AfterObjCmd(
ClientData clientData, /* Unused */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_WideInt ms = 0; /* Number of milliseconds to wait */
Tcl_Time wakeup;
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
int length;
int index;
static const char *const afterSubCmds[] = {
"cancel", "idle", "info", NULL
};
enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
ThreadSpecificData *tsdPtr = InitTimer();
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
/*
* Create the "after" information associated for this interpreter, if it
* doesn't already exist.
*/
assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL);
if (assocPtr == NULL) {
assocPtr = ckalloc(sizeof(AfterAssocData));
assocPtr->interp = interp;
assocPtr->firstAfterPtr = NULL;
Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr);
}
/*
* First lets see if the command was passed a number as the first argument.
*/
if (objv[1]->typePtr == &tclIntType
#ifndef TCL_WIDE_INT_IS_LONG
|| objv[1]->typePtr == &tclWideIntType
#endif
|| objv[1]->typePtr == &tclBignumType
|| (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0,
&index) != TCL_OK)) {
index = -1;
if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
const char *arg = Tcl_GetString(objv[1]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad argument \"%s\": must be"
" cancel, idle, info, or an integer", arg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
arg, NULL);
return TCL_ERROR;
}
}
/*
* At this point, either index = -1 and ms contains the number of ms
* to wait, or else index is the index of a subcommand.
*/
switch (index) {
case -1: {
if (ms < 0) {
ms = 0;
}
if (objc == 2) {
return AfterDelay(interp, ms);
}
afterPtr = ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
/*
* The variable below is used to generate unique identifiers for after
* commands. This id can wrap around, which can potentially cause
* problems. However, there are not likely to be problems in practice,
* because after commands can only be requested to about a month in
* the future, and wrap-around is unlikely to occur in less than about
* 1-10 years. Thus it's unlikely that any old ids will still be
* around when wrap-around occurs.
*/
afterPtr->id = tsdPtr->afterId;
tsdPtr->afterId += 1;
Tcl_GetTime(&wakeup);
wakeup.sec += (long)(ms / 1000);
wakeup.usec += ((long)(ms % 1000)) * 1000;
if (wakeup.usec > 1000000) {
wakeup.sec++;
wakeup.usec -= 1000000;
}
afterPtr->token = TclCreateAbsoluteTimerHandler(&wakeup,
AfterProc, afterPtr);
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
return TCL_OK;
}
case AFTER_CANCEL: {
Tcl_Obj *commandPtr;
const char *command, *tempCommand;
int tempLength;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "id|command");
return TCL_ERROR;
}
if (objc == 3) {
commandPtr = objv[2];
} else {
commandPtr = Tcl_ConcatObj(objc-2, objv+2);;
}
command = TclGetStringFromObj(commandPtr, &length);
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
tempCommand = TclGetStringFromObj(afterPtr->commandPtr,
&tempLength);
if ((length == tempLength)
&& !memcmp(command, tempCommand, (unsigned) length)) {
break;
}
}
if (afterPtr == NULL) {
afterPtr = GetAfterEvent(assocPtr, commandPtr);
}
if (objc != 3) {
Tcl_DecrRefCount(commandPtr);
}
if (afterPtr != NULL) {
if (afterPtr->token != NULL) {
Tcl_DeleteTimerHandler(afterPtr->token);
} else {
Tcl_CancelIdleCall(AfterProc, afterPtr);
}
FreeAfterPtr(afterPtr);
}
break;
}
case AFTER_IDLE:
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?");
return TCL_ERROR;
}
afterPtr = ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
afterPtr->id = tsdPtr->afterId;
tsdPtr->afterId += 1;
afterPtr->token = NULL;
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
Tcl_DoWhenIdle(AfterProc, afterPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
break;
case AFTER_INFO:
if (objc == 2) {
Tcl_Obj *resultObj = Tcl_NewObj();
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
if (assocPtr->interp == interp) {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf(
"after#%d", afterPtr->id));
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?id?");
return TCL_ERROR;
}
afterPtr = GetAfterEvent(assocPtr, objv[2]);
if (afterPtr == NULL) {
const char *eventStr = TclGetString(objv[2]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"event \"%s\" doesn't exist", eventStr));
Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL);
return TCL_ERROR;
} else {
Tcl_Obj *resultListPtr = Tcl_NewObj();
Tcl_ListObjAppendElement(interp, resultListPtr,
afterPtr->commandPtr);
Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
(afterPtr->token == NULL) ? "idle" : "timer", -1));
Tcl_SetObjResult(interp, resultListPtr);
}
break;
default:
Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
}
return TCL_OK;
}
void
Tcl_MainEx(
int argc, /* Number of arguments. */
TCHAR **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc,
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
Tcl_Interp *interp)
{
Tcl_Obj *path, *resultPtr, *argvPtr, *appName;
const char *encodingName = NULL;
int code, exitCode = 0;
Tcl_MainLoopProc *mainLoopProc;
Tcl_Channel chan;
InteractiveState is;
TclpSetInitialEncodings();
TclpFindExecutable((const char *)argv[0]);
Tcl_InitMemory(interp);
is.interp = interp;
is.prompt = PROMPT_START;
is.commandPtr = Tcl_NewObj();
/*
* If the application has not already set a startup script, parse the
* first few command line arguments to determine the script path and
* encoding.
*/
if (NULL == Tcl_GetStartupScript(NULL)) {
/*
* Check whether first 3 args (argv[1] - argv[3]) look like
* -encoding ENCODING FILENAME
* or like
* FILENAME
*/
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2], -1);
Tcl_SetStartupScript(NewNativeObj(argv[3], -1),
Tcl_GetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
argv += 3;
} else if ((argc > 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL);
argc--;
argv++;
}
}
path = Tcl_GetStartupScript(&encodingName);
if (path == NULL) {
appName = NewNativeObj(argv[0], -1);
} else {
appName = path;
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1));
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
is.tty = isatty(0);
Tcl_SetVar2Ex(interp, "tcl_interactive", NULL,
Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
Tcl_Preserve(interp);
if (appInitProc(interp) != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteChars(chan,
"application-specific initialization failed: ", -1);
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
}
if (Tcl_InterpDeleted(interp)) {
goto done;
}
if (Tcl_LimitExceeded(interp)) {
goto done;
}
if (TclFullFinalizationRequested()) {
/*
* Arrange for final deletion of the main interp
*/
/* ARGH Munchhausen effect */
Tcl_CreateExitHandler(FreeMainInterp, interp);
}
/*
* Invoke the script specified on the command line, if any. Must fetch it
* again, as the appInitProc might have reset it.
*/
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
Tcl_ResetResult(interp);
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr;
TclNewLiteralStringObj(keyPtr, "-errorinfo");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
Tcl_WriteObj(chan, valuePtr);
}
Tcl_WriteChars(chan, "\n", 1);
Tcl_DecrRefCount(options);
}
exitCode = 1;
}
goto done;
}
/*
* We're running interactively. Source a user-specific startup file if the
* application specified one and if the file exists.
*/
Tcl_SourceRCFile(interp);
if (Tcl_LimitExceeded(interp)) {
goto done;
}
/*
* Process commands from stdin until there's an end-of-file. Note that we
* need to fetch the standard channels again after every eval, since they
* may have been changed.
*/
Tcl_IncrRefCount(is.commandPtr);
/*
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
is.input = Tcl_GetStdChannel(TCL_STDIN);
while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
mainLoopProc = TclGetMainLoop();
if (mainLoopProc == NULL) {
int length;
if (is.tty) {
Prompt(interp, &is);
if (Tcl_InterpDeleted(interp)) {
break;
}
if (Tcl_LimitExceeded(interp)) {
break;
}
is.input = Tcl_GetStdChannel(TCL_STDIN);
if (is.input == NULL) {
break;
}
}
if (Tcl_IsShared(is.commandPtr)) {
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
}
length = Tcl_GetsObj(is.input, is.commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(is.input)) {
/*
* This can only happen if stdin has been set to
* non-blocking. In that case cycle back and try again.
* This sets up a tight polling loop (since we have no
* event loop running). If this causes bad CPU hogging, we
* might try toggling the blocking on stdin instead.
*/
continue;
}
/*
* Either EOF, or an error on stdin; we're done
*/
break;
}
/*
* Add the newline removed by Tcl_GetsObj back to the string. Have
* to add it back before testing completeness, because it can make
* a difference. [Bug 1775878]
*/
if (Tcl_IsShared(is.commandPtr)) {
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
}
Tcl_AppendToObj(is.commandPtr, "\n", 1);
if (!TclObjCommandComplete(is.commandPtr)) {
is.prompt = PROMPT_CONTINUE;
continue;
}
is.prompt = PROMPT_START;
/*
* The final newline is syntactically redundant, and causes some
* error messages troubles deeper in, so lop it back off.
*/
TclGetStringFromObj(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);
TclGetStringFromObj(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);
}
