diff options
| -rw-r--r-- | generic/tclEnv.c | 342 | ||||
| -rw-r--r-- | generic/tclHash.c | 249 | ||||
| -rw-r--r-- | generic/tclIndexObj.c | 371 | ||||
| -rw-r--r-- | generic/tclMain.c | 369 | ||||
| -rw-r--r-- | generic/tclNotify.c | 511 | ||||
| -rw-r--r-- | generic/tclParse.c | 1677 | ||||
| -rw-r--r-- | generic/tclParseExpr.c | 1103 | ||||
| -rw-r--r-- | generic/tclPathObj.c | 1813 | ||||
| -rw-r--r-- | generic/tclPipe.c | 413 | ||||
| -rw-r--r-- | generic/tclPkgConfig.c | 149 | ||||
| -rw-r--r-- | generic/tclProc.c | 567 | ||||
| -rw-r--r-- | generic/tclRegexp.c | 284 | ||||
| -rw-r--r-- | generic/tclScan.c | 971 | ||||
| -rw-r--r-- | generic/tclThread.c | 116 | ||||
| -rw-r--r-- | generic/tclUtf.c | 415 |
15 files changed, 4823 insertions, 4527 deletions
diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 4ceb4fb..287a3a8 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -1,18 +1,18 @@ -/* +/* * tclEnv.c -- * - * Tcl support for environment variables, including a setenv - * procedure. This file contains the generic portion of the - * environment module. It is primarily responsible for keeping - * the "env" arrays in sync with the system environment variables. + * Tcl support for environment variables, including a setenv function. + * This file contains the generic portion of the environment module. It + * is primarily responsible for keeping the "env" arrays in sync with the + * system environment variables. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEnv.c,v 1.24 2005/05/10 18:34:34 kennykb Exp $ + * RCS: @(#) $Id: tclEnv.c,v 1.25 2005/07/21 14:38:31 dkf Exp $ */ #include "tclInt.h" @@ -41,11 +41,11 @@ char **environ = NULL; #endif /* - * Declarations for local procedures defined in this file: + * Declarations for local functions defined in this file: */ static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, CONST char *name1, + Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags)); static void ReplaceString _ANSI_ARGS_((CONST char *oldStr, char *newStr)); @@ -62,20 +62,19 @@ static void TclCygwinPutenv _ANSI_ARGS_((CONST char *string)); * * TclSetupEnv -- * - * This procedure is invoked for an interpreter to make environment - * variables accessible from that interpreter via the "env" - * associative array. + * This function is invoked for an interpreter to make environment + * variables accessible from that interpreter via the "env" associative + * array. * * Results: * None. * * Side effects: - * The interpreter is added to a list of interpreters managed - * by us, so that its view of envariables can be kept consistent - * with the view in other interpreters. If this is the first - * call to TclSetupEnv, then additional initialization happens, - * such as copying the environment to dynamically-allocated space - * for ease of management. + * The interpreter is added to a list of interpreters managed by us, so + * that its view of envariables can be kept consistent with the view in + * other interpreters. If this is the first call to TclSetupEnv, then + * additional initialization happens, such as copying the environment to + * dynamically-allocated space for ease of management. * *---------------------------------------------------------------------- */ @@ -97,28 +96,28 @@ TclSetupEnv(interp) #endif /* - * Synchronize the values in the environ array with the contents - * of the Tcl "env" variable. To do this: + * Synchronize the values in the environ array with the contents of the + * Tcl "env" variable. To do this: * 1) Remove the trace that fires when the "env" var is unset. * 2) Unset the "env" variable. - * 3) If there are no environ variables, create an empty "env" - * array. Otherwise populate the array with current values. + * 3) If there are no environ variables, create an empty "env" array. + * Otherwise populate the array with current values. * 4) Add a trace that synchronizes the "env" array. */ - + Tcl_UntraceVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, (ClientData) NULL); - - Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); - + + Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); + if (environ[0] == NULL) { Tcl_Obj *varNamePtr; - + varNamePtr = Tcl_NewStringObj("env", -1); Tcl_IncrRefCount(varNamePtr); - TclArraySet(interp, varNamePtr, NULL); + TclArraySet(interp, varNamePtr, NULL); Tcl_DecrRefCount(varNamePtr); } else { Tcl_MutexLock(&envMutex); @@ -130,12 +129,12 @@ TclSetupEnv(interp) * This condition seem to happen occasionally under some * versions of Solaris; ignore the entry. */ - + continue; } p2++; p2[-1] = '\0'; - Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY); Tcl_DStringFree(&envString); } Tcl_MutexUnlock(&envMutex); @@ -152,12 +151,12 @@ TclSetupEnv(interp) * * TclSetEnv -- * - * Set an environment variable, replacing an existing value - * or creating a new variable if there doesn't exist a variable - * by the given name. This procedure is intended to be a - * stand-in for the UNIX "setenv" procedure so that applications - * using that procedure will interface properly to Tcl. To make - * it a stand-in, the Makefile must define "TclSetEnv" to "setenv". + * Set an environment variable, replacing an existing value or creating a + * new variable if there doesn't exist a variable by the given name. + * This function is intended to be a stand-in for the UNIX "setenv" + * function so that applications using that function will interface + * properly to Tcl. To make it a stand-in, the Makefile must define + * "TclSetEnv" to "setenv". * * Results: * None. @@ -170,8 +169,8 @@ TclSetupEnv(interp) void TclSetEnv(name, value) - CONST char *name; /* Name of variable whose value is to be - * set (UTF-8). */ + CONST char *name; /* Name of variable whose value is to be set + * (UTF-8). */ CONST char *value; /* New value for variable (UTF-8). */ { Tcl_DString envString; @@ -180,9 +179,9 @@ TclSetEnv(name, value) CONST char *p2; /* - * Figure out where the entry is going to go. If the name doesn't - * already exist, enlarge the array if necessary to make room. If the - * name exists, free its old entry. + * Figure out where the entry is going to go. If the name doesn't already + * exist, enlarge the array if necessary to make room. If the name exists, + * free its old entry. */ Tcl_MutexLock(&envMutex); @@ -204,25 +203,25 @@ TclSetEnv(name, value) environSize = length + 5; #if defined(__APPLE__) && defined(__DYNAMIC__) { - char ***e = _NSGetEnviron(); - *e = environ; + char ***e = _NSGetEnviron(); + *e = environ; } -#endif +#endif /* __APPLE__ && __DYNAMIC__ */ } index = length; environ[index + 1] = NULL; -#endif +#endif /* USE_PUTENV */ oldValue = NULL; nameLength = strlen(name); } else { CONST char *env; /* - * Compare the new value to the existing value. If they're - * the same then quit immediately (e.g. don't rewrite the - * value or propagate it to other interpreters). Otherwise, - * when there are N interpreters there will be N! propagations - * of the same value among the interpreters. + * Compare the new value to the existing value. If they're the same + * then quit immediately (e.g. don't rewrite the value or propagate it + * to other interpreters). Otherwise, when there are N interpreters + * there will be N! propagations of the same value among the + * interpreters. */ env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString); @@ -236,12 +235,11 @@ TclSetEnv(name, value) oldValue = environ[index]; nameLength = length; } - /* - * Create a new entry. Build a complete UTF string that contains - * a "name=value" pattern. Then convert the string to the native - * encoding, and set the environ array value. + * Create a new entry. Build a complete UTF string that contains a + * "name=value" pattern. Then convert the string to the native encoding, + * and set the environ array value. */ p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2)); @@ -253,7 +251,7 @@ TclSetEnv(name, value) /* * Copy the native string to heap memory. */ - + p = (char *) ckrealloc(p, (unsigned) (strlen(p2) + 1)); strcpy(p, p2); Tcl_DStringFree(&envString); @@ -270,29 +268,32 @@ TclSetEnv(name, value) #endif /* - * Watch out for versions of putenv that copy the string (e.g. VC++). - * In this case we need to free the string immediately. Otherwise - * update the string in the cache. + * Watch out for versions of putenv that copy the string (e.g. VC++). In + * this case we need to free the string immediately. Otherwise update the + * string in the cache. */ if ((index != -1) && (environ[index] == p)) { ReplaceString(oldValue, p); #ifdef HAVE_PUTENV_THAT_COPIES } else { - /* This putenv() copies instead of taking ownership */ + /* + * This putenv() copies instead of taking ownership. + */ + ckfree(p); #endif } Tcl_MutexUnlock(&envMutex); - + if (!strcmp(name, "HOME")) { - /* - * If the user's home directory has changed, we must invalidate - * the filesystem cache, because '~' expansions will now be - * incorrect. + /* + * If the user's home directory has changed, we must invalidate the + * filesystem cache, because '~' expansions will now be incorrect. */ - Tcl_FSMountsChanged(NULL); + + Tcl_FSMountsChanged(NULL); } } @@ -301,30 +302,29 @@ TclSetEnv(name, value) * * Tcl_PutEnv -- * - * Set an environment variable. Similar to setenv except that - * the information is passed in a single string of the form - * NAME=value, rather than as separate name strings. This procedure - * is intended to be a stand-in for the UNIX "putenv" procedure - * so that applications using that procedure will interface - * properly to Tcl. To make it a stand-in, the Makefile will - * define "Tcl_PutEnv" to "putenv". + * Set an environment variable. Similar to setenv except that the + * information is passed in a single string of the form NAME=value, + * rather than as separate name strings. This function is intended to be + * a stand-in for the UNIX "putenv" function so that applications using + * that function will interface properly to Tcl. To make it a stand-in, + * the Makefile will define "Tcl_PutEnv" to "putenv". * * Results: * None. * * Side effects: - * The environ array gets updated, as do all of the interpreters - * that we manage. + * The environ array gets updated, as do all of the interpreters that we + * manage. * *---------------------------------------------------------------------- */ int Tcl_PutEnv(assignment) - CONST char *assignment; /* Info about environment variable in the - * form NAME=value. (native) */ + CONST char *assignment; /* Info about environment variable in the form + * NAME=value. (native) */ { - Tcl_DString nameString; + Tcl_DString nameString; CONST char *name; char *value; @@ -333,9 +333,8 @@ Tcl_PutEnv(assignment) } /* - * First convert the native string to UTF. Then separate the - * string into name and value parts, and call TclSetEnv to do - * all of the real work. + * First convert the native string to UTF. Then separate the string into + * name and value parts, and call TclSetEnv to do all of the real work. */ name = Tcl_ExternalToUtfDString(NULL, assignment, -1, &nameString); @@ -355,11 +354,10 @@ Tcl_PutEnv(assignment) * * TclUnsetEnv -- * - * Remove an environment variable, updating the "env" arrays - * in all interpreters managed by us. This function is intended - * to replace the UNIX "unsetenv" function (but to do this the - * Makefile must be modified to redefine "TclUnsetEnv" to - * "unsetenv". + * Remove an environment variable, updating the "env" arrays in all + * interpreters managed by us. This function is intended to replace the + * UNIX "unsetenv" function (but to do this the Makefile must be modified + * to redefine "TclUnsetEnv" to "unsetenv". * * Results: * None. @@ -388,10 +386,10 @@ TclUnsetEnv(name) index = TclpFindVariable(name, &length); /* - * First make sure that the environment variable exists to avoid - * doing needless work and to avoid recursion on the unset. + * First make sure that the environment variable exists to avoid doing + * needless work and to avoid recursion on the unset. */ - + if (index == -1) { Tcl_MutexUnlock(&envMutex); return; @@ -403,8 +401,8 @@ TclUnsetEnv(name) oldValue = environ[index]; /* - * Update the system environment. This must be done before we - * update the interpreters or we will recurse. + * Update the system environment. This must be done before we update the + * interpreters or we will recurse. */ #ifdef USE_PUTENV @@ -412,7 +410,7 @@ TclUnsetEnv(name) memcpy((VOID *) string, (VOID *) name, (size_t) length); string[length] = '='; string[length+1] = '\0'; - + Tcl_UtfToExternalDString(NULL, string, -1, &envString); string = ckrealloc(string, (unsigned) (Tcl_DStringLength(&envString)+1)); strcpy(string, Tcl_DStringValue(&envString)); @@ -421,16 +419,19 @@ TclUnsetEnv(name) putenv(string); /* - * Watch out for versions of putenv that copy the string (e.g. VC++). - * In this case we need to free the string immediately. Otherwise - * update the string in the cache. + * Watch out for versions of putenv that copy the string (e.g. VC++). In + * this case we need to free the string immediately. Otherwise update the + * string in the cache. */ if (environ[index] == string) { ReplaceString(oldValue, string); #ifdef HAVE_PUTENV_THAT_COPIES } else { - /* This putenv() copies instead of taking ownership */ + /* + * This putenv() copies instead of taking ownership. + */ + ckfree(string); #endif } @@ -456,10 +457,10 @@ TclUnsetEnv(name) * * Results: * The result is a pointer to a string specifying the value of the - * environment variable, or NULL if that environment variable does - * not exist. Storage for the result string is allocated in valuePtr; - * the caller must call Tcl_DStringFree() when the result is no - * longer needed. + * environment variable, or NULL if that environment variable does not + * exist. Storage for the result string is allocated in valuePtr; the + * caller must call Tcl_DStringFree() when the result is no longer + * needed. * * Side effects: * None. @@ -471,8 +472,8 @@ CONST char * TclGetEnv(name, valuePtr) CONST char *name; /* Name of environment variable to find * (UTF-8). */ - Tcl_DString *valuePtr; /* Uninitialized or free DString in which - * the value of the environment variable is + Tcl_DString *valuePtr; /* Uninitialized or free DString in which the + * value of the environment variable is * stored. */ { int length, index; @@ -483,7 +484,7 @@ TclGetEnv(name, valuePtr) result = NULL; if (index != -1) { Tcl_DString envStr; - + result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr); result += length; if (*result == '=') { @@ -505,18 +506,17 @@ TclGetEnv(name, valuePtr) * * EnvTraceProc -- * - * This procedure is invoked whenever an environment variable - * is read, modified or deleted. It propagates the change to the global - * "environ" array. + * This function is invoked whenever an environment variable is read, + * modified or deleted. It propagates the change to the global "environ" + * array. * * Results: * Always returns NULL to indicate success. * * Side effects: - * Environment variable changes get propagated. If the whole - * "env" array is deleted, then we stop managing things for - * this interpreter (usually this happens because the whole - * interpreter is being deleted). + * Environment variable changes get propagated. If the whole "env" array + * is deleted, then we stop managing things for this interpreter (usually + * this happens because the whole interpreter is being deleted). * *---------------------------------------------------------------------- */ @@ -525,11 +525,11 @@ TclGetEnv(name, valuePtr) static char * EnvTraceProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Interpreter whose "env" variable is - * being modified. */ + Tcl_Interp *interp; /* Interpreter whose "env" variable is being + * modified. */ CONST char *name1; /* Better be "env". */ - CONST char *name2; /* Name of variable being modified, or NULL - * if whole array is being deleted (UTF-8). */ + CONST char *name2; /* Name of variable being modified, or NULL if + * whole array is being deleted (UTF-8). */ int flags; /* Indicates what's happening. */ { /* @@ -544,7 +544,7 @@ EnvTraceProc(clientData, interp, name1, name2, flags) /* * If name2 is NULL, then return and do nothing. */ - + if (name2 == NULL) { return NULL; } @@ -555,7 +555,7 @@ EnvTraceProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_WRITES) { CONST char *value; - + value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY); TclSetEnv(name2, value); } @@ -591,9 +591,9 @@ EnvTraceProc(clientData, interp, name1, name2, flags) * * ReplaceString -- * - * Replace one string with another in the environment variable - * cache. The cache keeps track of all of the environment - * variables that Tcl has modified so they can be freed later. + * Replace one string with another in the environment variable cache. + * The cache keeps track of all of the environment variables that Tcl has + * modified so they can be freed later. * * Results: * None. @@ -613,10 +613,10 @@ ReplaceString(oldStr, newStr) char **newCache; /* - * Check to see if the old value was allocated by Tcl. If so, - * it needs to be deallocated to avoid memory leaks. Note that this - * algorithm is O(n), not O(1). This will result in n-squared behavior - * if lots of environment changes are being made. + * Check to see if the old value was allocated by Tcl. If so, it needs to + * be deallocated to avoid memory leaks. Note that this algorithm is O(n), + * not O(1). This will result in n-squared behavior if lots of environment + * changes are being made. */ for (i = 0; i < cacheSize; i++) { @@ -632,7 +632,7 @@ ReplaceString(oldStr, newStr) if (environCache[i]) { ckfree(environCache[i]); } - + if (newStr) { environCache[i] = newStr; } else { @@ -641,16 +641,16 @@ ReplaceString(oldStr, newStr) } environCache[cacheSize-1] = NULL; } - } else { - int allocatedSize = (cacheSize + 5) * sizeof(char *); + } else { + int allocatedSize = (cacheSize + 5) * sizeof(char *); /* * We need to grow the cache in order to hold the new string. */ newCache = (char **) ckalloc((unsigned) allocatedSize); - (VOID *) memset(newCache, (int) 0, (size_t) allocatedSize); - + (VOID *) memset(newCache, (int) 0, (size_t) allocatedSize); + if (environCache) { memcpy((VOID *) newCache, (VOID *) environCache, (size_t) (cacheSize * sizeof(char*))); @@ -668,9 +668,9 @@ ReplaceString(oldStr, newStr) * * TclFinalizeEnvironment -- * - * This function releases any storage allocated by this module - * that isn't still in use by the global environment. Any - * strings that are still in the environment will be leaked. + * This function releases any storage allocated by this module that isn't + * still in use by the global environment. Any strings that are still in + * the environment will be leaked. * * Results: * None. @@ -686,8 +686,8 @@ TclFinalizeEnvironment() { /* * For now we just deallocate the cache array and none of the environment - * strings. This may leak more memory that strictly necessary, since some - * of the strings may no longer be in the environment. However, + * strings. This may leak more memory that strictly necessary, since some + * of the strings may no longer be in the environment. However, * determining which ones are ok to delete is n-squared, and is pretty * unlikely, so we don't bother. */ @@ -695,9 +695,9 @@ TclFinalizeEnvironment() if (environCache) { ckfree((char *) environCache); environCache = NULL; - cacheSize = 0; + cacheSize = 0; #ifndef USE_PUTENV - environSize = 0; + environSize = 0; #endif } } @@ -719,26 +719,33 @@ TclCygwinPutenv(str) { char *name, *value; - /* Get the name and value, so that we can change the environment - variable for Windows. */ - name = (char *) alloca (strlen (str) + 1); - strcpy (name, str); - for (value = name; *value != '=' && *value != '\0'; ++value) - ; + /* + * Get the name and value, so that we can change the environment variable + * for Windows. + */ + + name = (char *) alloca(strlen(str) + 1); + strcpy(name, str); + for (value=name ; *value!='=' && *value!='\0' ; ++value) { + /* Empty body */ + } if (*value == '\0') { - /* Can't happen. */ - return; - } + /* Can't happen. */ + return; + } *value = '\0'; ++value; if (*value == '\0') { value = NULL; } - /* Set the cygwin environment variable. */ + /* + * Set the cygwin environment variable. + */ + #undef putenv if (value == NULL) { - unsetenv (name); + unsetenv(name); } else { putenv(str); } @@ -751,34 +758,49 @@ TclCygwinPutenv(str) * may have set the path to a Windows path, or, worse, appended or * prepended a Windows path to PATH. */ - if (strcmp (name, "PATH") != 0) { - /* If this is Path, eliminate any PATH variable, to prevent any - confusion. */ - if (strcmp (name, "Path") == 0) { - SetEnvironmentVariable ("PATH", (char *) NULL); - unsetenv ("PATH"); + + if (strcmp(name, "PATH") != 0) { + /* + * If this is Path, eliminate any PATH variable, to prevent any + * confusion. + */ + + if (strcmp(name, "Path") == 0) { + SetEnvironmentVariable("PATH", (char *) NULL); + unsetenv("PATH"); } - SetEnvironmentVariable (name, value); + SetEnvironmentVariable(name, value); } else { char *buf; - /* Eliminate any Path variable, to prevent any confusion. */ - SetEnvironmentVariable ("Path", (char *) NULL); - unsetenv ("Path"); + /* + * Eliminate any Path variable, to prevent any confusion. + */ + + SetEnvironmentVariable("Path", (char *) NULL); + unsetenv("Path"); if (value == NULL) { buf = NULL; } else { int size; - size = cygwin_posix_to_win32_path_list_buf_size (value); - buf = (char *) alloca (size + 1); - cygwin_posix_to_win32_path_list (value, buf); + size = cygwin_posix_to_win32_path_list_buf_size(value); + buf = (char *) alloca(size + 1); + cygwin_posix_to_win32_path_list(value, buf); } - SetEnvironmentVariable (name, buf); + SetEnvironmentVariable(name, buf); } } #endif /* __CYGWIN__ && __WIN32__ */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclHash.c b/generic/tclHash.c index 14de98a..861eb47 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -7,10 +7,10 @@ * Copyright (c) 1991-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclHash.c,v 1.22 2004/11/11 01:17:50 das Exp $ + * RCS: @(#) $Id: tclHash.c,v 1.23 2005/07/21 14:38:32 dkf Exp $ */ #include "tclInt.h" @@ -25,18 +25,17 @@ #endif /* - * When there are this many entries per bucket, on average, rebuild - * the hash table to make it larger. + * When there are this many entries per bucket, on average, rebuild the hash + * table to make it larger. */ #define REBUILD_MULTIPLIER 3 /* - * The following macro takes a preliminary integer hash value and - * produces an index into a hash tables bucket list. The idea is - * to make it so that preliminary values that are arbitrarily similar - * will end up in different buckets. The hash function was taken - * from a random-number generator. + * The following macro takes a preliminary integer hash value and produces an + * index into a hash tables bucket list. The idea is to make it so that + * preliminary values that are arbitrarily similar will end up in different + * buckets. The hash function was taken from a random-number generator. */ #define RANDOM_INDEX(tablePtr, i) \ @@ -78,7 +77,7 @@ static unsigned int HashStringKey _ANSI_ARGS_(( Tcl_HashTable *tablePtr, VOID *keyPtr)); /* - * Procedure prototypes for static procedures in this file: + * Function prototypes for static functions in this file: */ #if TCL_PRESERVE_BINARY_COMPATABILITY @@ -116,15 +115,14 @@ Tcl_HashKeyType tclStringHashKeyType = { AllocStringEntry, /* allocEntryProc */ NULL /* freeEntryProc */ }; - /* *---------------------------------------------------------------------- * * Tcl_InitHashTable -- * - * Given storage for a hash table, set up the fields to prepare - * the hash table for use. + * Given storage for a hash table, set up the fields to prepare the hash + * table for use. * * Results: * None. @@ -139,18 +137,19 @@ Tcl_HashKeyType tclStringHashKeyType = { #undef Tcl_InitHashTable void Tcl_InitHashTable(tablePtr, keyType) - register Tcl_HashTable *tablePtr; /* Pointer to table record, which - * is supplied by the caller. */ + register Tcl_HashTable *tablePtr; /* Pointer to table record, which is + * supplied by the caller. */ int keyType; /* Type of keys to use in table: * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, * or an integer >= 2. */ { /* - * Use a special value to inform the extended version that it must - * not access any of the new fields in the Tcl_HashTable. If an - * extension is rebuilt then any calls to this function will be - * redirected to the extended version by a macro. + * Use a special value to inform the extended version that it must not + * access any of the new fields in the Tcl_HashTable. If an extension is + * rebuilt then any calls to this function will be redirected to the + * extended version by a macro. */ + Tcl_InitCustomHashTable(tablePtr, keyType, (Tcl_HashKeyType *) -1); } @@ -159,9 +158,9 @@ Tcl_InitHashTable(tablePtr, keyType) * * Tcl_InitCustomHashTable -- * - * Given storage for a hash table, set up the fields to prepare - * the hash table for use. This is an extended version of - * Tcl_InitHashTable which supports user defined keys. + * Given storage for a hash table, set up the fields to prepare the hash + * table for use. This is an extended version of Tcl_InitHashTable which + * supports user defined keys. * * Results: * None. @@ -175,13 +174,13 @@ Tcl_InitHashTable(tablePtr, keyType) void Tcl_InitCustomHashTable(tablePtr, keyType, typePtr) - register Tcl_HashTable *tablePtr; /* Pointer to table record, which - * is supplied by the caller. */ + register Tcl_HashTable *tablePtr; /* Pointer to table record, which is + * supplied by the caller. */ int keyType; /* Type of keys to use in table: * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, * TCL_CUSTOM_TYPE_KEYS, - * TCL_CUSTOM_PTR_KEYS, or an - * integer >= 2. */ + * TCL_CUSTOM_PTR_KEYS, or an integer + * >= 2. */ Tcl_HashKeyType *typePtr; /* Pointer to structure which defines * the behaviour of this table. */ { @@ -210,14 +209,14 @@ Tcl_InitCustomHashTable(tablePtr, keyType, typePtr) */ } else if (typePtr != (Tcl_HashKeyType *) -1) { /* - * The caller is requesting a customized hash table so it must be - * an extended version. + * The caller is requesting a customized hash table so it must be an + * extended version. */ + tablePtr->typePtr = typePtr; } else { /* - * The caller has not been rebuilt so the hash table is not - * extended. + * The caller has not been rebuilt so the hash table is not extended. */ } #else @@ -225,6 +224,7 @@ Tcl_InitCustomHashTable(tablePtr, keyType, typePtr) /* * Use the key type to decide which key type is needed. */ + if (keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; } else if (keyType == TCL_ONE_WORD_KEYS) { @@ -238,10 +238,11 @@ Tcl_InitCustomHashTable(tablePtr, keyType, typePtr) } } else if (typePtr == (Tcl_HashKeyType *) -1) { /* - * If the caller has not been rebuilt then we cannot continue as - * the hash table is not an extended version. + * If the caller has not been rebuilt then we cannot continue as the + * hash table is not an extended version. */ - Tcl_Panic ("Hash table is not compatible"); + + Tcl_Panic("Hash table is not compatible"); } tablePtr->typePtr = typePtr; #endif @@ -255,8 +256,8 @@ Tcl_InitCustomHashTable(tablePtr, keyType, typePtr) * Given a hash table find the entry with a matching key. * * Results: - * The return value is a token for the matching entry in the - * hash table, or NULL if there was no matching entry. + * The return value is a token for the matching entry in the hash table, + * or NULL if there was no matching entry. * * Side effects: * None. @@ -312,7 +313,7 @@ Tcl_FindHashEntry(tablePtr, key) if (typePtr->compareKeysProc) { Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc; for (hPtr = tablePtr->buckets[index]; hPtr != NULL; - hPtr = hPtr->nextPtr) { + hPtr = hPtr->nextPtr) { #if TCL_HASH_KEY_STORE_HASH if (hash != (unsigned int) hPtr->hash) { continue; @@ -324,7 +325,7 @@ Tcl_FindHashEntry(tablePtr, key) } } else { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; - hPtr = hPtr->nextPtr) { + hPtr = hPtr->nextPtr) { #if TCL_HASH_KEY_STORE_HASH if (hash != (unsigned int) hPtr->hash) { continue; @@ -344,15 +345,15 @@ Tcl_FindHashEntry(tablePtr, key) * * Tcl_CreateHashEntry -- * - * Given a hash table with string keys, and a string key, find - * the entry with a matching key. If there is no matching entry, - * then create a new entry that does match. + * Given a hash table with string keys, and a string key, find the entry + * with a matching key. If there is no matching entry, then create a new + * entry that does match. * * Results: - * The return value is a pointer to the matching entry. If this - * is a newly-created entry, then *newPtr will be set to a non-zero - * value; otherwise *newPtr will be set to 0. If this is a new - * entry the value stored in the entry will initially be 0. + * The return value is a pointer to the matching entry. If this is a + * newly-created entry, then *newPtr will be set to a non-zero value; + * otherwise *newPtr will be set to 0. If this is a new entry the value + * stored in the entry will initially be 0. * * Side effects: * A new entry may be added to the hash table. @@ -365,8 +366,8 @@ Tcl_CreateHashEntry(tablePtr, key, newPtr) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ CONST char *key; /* Key to use to find or create matching * entry. */ - int *newPtr; /* Store info here telling whether a new - * entry was created. */ + int *newPtr; /* Store info here telling whether a new entry + * was created. */ { register Tcl_HashEntry *hPtr; Tcl_HashKeyType *typePtr; @@ -411,7 +412,7 @@ Tcl_CreateHashEntry(tablePtr, key, newPtr) if (typePtr->compareKeysProc) { Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc; for (hPtr = tablePtr->buckets[index]; hPtr != NULL; - hPtr = hPtr->nextPtr) { + hPtr = hPtr->nextPtr) { #if TCL_HASH_KEY_STORE_HASH if (hash != (unsigned int) hPtr->hash) { continue; @@ -424,7 +425,7 @@ Tcl_CreateHashEntry(tablePtr, key, newPtr) } } else { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; - hPtr = hPtr->nextPtr) { + hPtr = hPtr->nextPtr) { #if TCL_HASH_KEY_STORE_HASH if (hash != (unsigned int) hPtr->hash) { continue; @@ -438,7 +439,7 @@ Tcl_CreateHashEntry(tablePtr, key, newPtr) } /* - * Entry not found. Add a new one to the bucket. + * Entry not found. Add a new one to the bucket. */ *newPtr = 1; @@ -467,8 +468,8 @@ Tcl_CreateHashEntry(tablePtr, key, newPtr) tablePtr->numEntries++; /* - * If the table has exceeded a decent size, rebuild it with many - * more buckets. + * If the table has exceeded a decent size, rebuild it with many more + * buckets. */ if (tablePtr->numEntries >= tablePtr->rebuildSize) { @@ -488,10 +489,9 @@ Tcl_CreateHashEntry(tablePtr, key, newPtr) * None. * * Side effects: - * The entry given by entryPtr is deleted from its table and - * should never again be used by the caller. It is up to the - * caller to free the clientData field of the entry, if that - * is relevant. + * The entry given by entryPtr is deleted from its table and should never + * again be used by the caller. It is up to the caller to free the + * clientData field of the entry, if that is relevant. * *---------------------------------------------------------------------- */ @@ -565,8 +565,8 @@ Tcl_DeleteHashEntry(entryPtr) * * Tcl_DeleteHashTable -- * - * Free up everything associated with a hash table except for - * the record for the table itself. + * Free up everything associated with a hash table except for the record + * for the table itself. * * Results: * None. @@ -647,16 +647,14 @@ Tcl_DeleteHashTable(tablePtr) * * Tcl_FirstHashEntry -- * - * Locate the first entry in a hash table and set up a record - * that can be used to step through all the remaining entries - * of the table. + * Locate the first entry in a hash table and set up a record that can be + * used to step through all the remaining entries of the table. * * Results: - * The return value is a pointer to the first entry in tablePtr, - * or NULL if tablePtr has no entries in it. The memory at - * *searchPtr is initialized so that subsequent calls to - * Tcl_NextHashEntry will return all of the entries in the table, - * one at a time. + * The return value is a pointer to the first entry in tablePtr, or NULL + * if tablePtr has no entries in it. The memory at *searchPtr is + * initialized so that subsequent calls to Tcl_NextHashEntry will return + * all of the entries in the table, one at a time. * * Side effects: * None. @@ -666,9 +664,9 @@ Tcl_DeleteHashTable(tablePtr) Tcl_HashEntry * Tcl_FirstHashEntry(tablePtr, searchPtr) - Tcl_HashTable *tablePtr; /* Table to search. */ - Tcl_HashSearch *searchPtr; /* Place to store information about - * progress through the table. */ + Tcl_HashTable *tablePtr; /* Table to search. */ + Tcl_HashSearch *searchPtr; /* Place to store information about progress + * through the table. */ { searchPtr->tablePtr = tablePtr; searchPtr->nextIndex = 0; @@ -682,12 +680,12 @@ Tcl_FirstHashEntry(tablePtr, searchPtr) * Tcl_NextHashEntry -- * * Once a hash table enumeration has been initiated by calling - * Tcl_FirstHashEntry, this procedure may be called to return - * successive elements of the table. + * Tcl_FirstHashEntry, this function may be called to return successive + * elements of the table. * * Results: - * The return value is the next entry in the hash table being - * enumerated, or NULL if the end of the table is reached. + * The return value is the next entry in the hash table being enumerated, + * or NULL if the end of the table is reached. * * Side effects: * None. @@ -697,10 +695,11 @@ Tcl_FirstHashEntry(tablePtr, searchPtr) Tcl_HashEntry * Tcl_NextHashEntry(searchPtr) - register Tcl_HashSearch *searchPtr; /* Place to store information about - * progress through the table. Must - * have been initialized by calling - * Tcl_FirstHashEntry. */ + register Tcl_HashSearch *searchPtr; + /* Place to store information about progress + * through the table. Must have been + * initialized by calling + * Tcl_FirstHashEntry. */ { Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr = searchPtr->tablePtr; @@ -723,13 +722,12 @@ Tcl_NextHashEntry(searchPtr) * * Tcl_HashStats -- * - * Return statistics describing the layout of the hash table - * in its hash buckets. + * Return statistics describing the layout of the hash table in its hash + * buckets. * * Results: - * The return value is a malloc-ed string containing information - * about tablePtr. It is the caller's responsibility to free - * this string. + * The return value is a malloc-ed string containing information about + * tablePtr. It is the caller's responsibility to free this string. * * Side effects: * None. @@ -739,7 +737,7 @@ Tcl_NextHashEntry(searchPtr) CONST char * Tcl_HashStats(tablePtr) - Tcl_HashTable *tablePtr; /* Table for which to produce stats. */ + Tcl_HashTable *tablePtr; /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 int count[NUM_COUNTERS], overflow, i, j; @@ -795,6 +793,7 @@ Tcl_HashStats(tablePtr) /* * Print out the histogram and a few other pieces of information. */ + if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { result = (char *) TclpSysAlloc((unsigned) (NUM_COUNTERS*60) + 300, 0); } else { @@ -866,8 +865,8 @@ AllocArrayEntry(tablePtr, keyPtr) * Compares two array keys. * * Results: - * The return value is 0 if they are different and 1 if they are - * the same. + * The return value is 0 if they are different and 1 if they are the + * same. * * Side effects: * None. @@ -901,8 +900,8 @@ CompareArrayKeys(keyPtr, hPtr) * * HashArrayKey -- * - * Compute a one-word summary of an array, which can be - * used to generate a hash index. + * Compute a one-word summary of an array, which can be used to generate + * a hash index. * * Results: * The return value is a one-word summary of the information in @@ -973,8 +972,8 @@ AllocStringEntry(tablePtr, keyPtr) * Compares two string keys. * * Results: - * The return value is 0 if they are different and 1 if they are - * the same. + * The return value is 0 if they are different and 1 if they are the + * same. * * Side effects: * None. @@ -1010,12 +1009,11 @@ CompareStringKeys(keyPtr, hPtr) * * HashStringKey -- * - * Compute a one-word summary of a text string, which can be - * used to generate a hash index. + * Compute a one-word summary of a text string, which can be used to + * generate a hash index. * * Results: - * The return value is a one-word summary of the information in - * string. + * The return value is a one-word summary of the information in string. * * Side effects: * None. @@ -1033,19 +1031,20 @@ HashStringKey(tablePtr, keyPtr) register int c; /* - * I tried a zillion different hash functions and asked many other - * people for advice. Many people had their own favorite functions, - * all different, but no-one had much idea why they were good ones. - * I chose the one below (multiply by 9 and add new character) - * because of the following reasons: + * I tried a zillion different hash functions and asked many other people + * for advice. Many people had their own favorite functions, all + * different, but no-one had much idea why they were good ones. I chose + * the one below (multiply by 9 and add new character) because of the + * following reasons: * - * 1. Multiplying by 10 is perfect for keys that are decimal strings, - * and multiplying by 9 is just about as good. - * 2. Times-9 is (shift-left-3) plus (old). This means that each - * character's bits hang around in the low-order bits of the - * hash value for ever, plus they spread fairly rapidly up to - * the high-order bits to fill out the hash value. This seems - * works well both for decimal and non-decimal strings. + * 1. Multiplying by 10 is perfect for keys that are decimal strings, and + * multiplying by 9 is just about as good. + * 2. Times-9 is (shift-left-3) plus (old). This means that each + * character's bits hang around in the low-order bits of the hash value + * for ever, plus they spread fairly rapidly up to the high-order bits + * to fill out the hash value. This seems works well both for decimal + * and non-decimal strings, but isn't strong against maliciously-chosen + * keys. */ result = 0; @@ -1062,12 +1061,11 @@ HashStringKey(tablePtr, keyPtr) * * BogusFind -- * - * This procedure is invoked when an Tcl_FindHashEntry is called - * on a table that has been deleted. + * This function is invoked when an Tcl_FindHashEntry is called on a + * table that has been deleted. * * Results: - * If Tcl_Panic returns (which it shouldn't) this procedure returns - * NULL. + * If Tcl_Panic returns (which it shouldn't) this function returns NULL. * * Side effects: * Generates a panic. @@ -1090,12 +1088,11 @@ BogusFind(tablePtr, key) * * BogusCreate -- * - * This procedure is invoked when an Tcl_CreateHashEntry is called - * on a table that has been deleted. + * This function is invoked when an Tcl_CreateHashEntry is called on a + * table that has been deleted. * * Results: - * If panic returns (which it shouldn't) this procedure returns - * NULL. + * If panic returns (which it shouldn't) this function returns NULL. * * Side effects: * Generates a panic. @@ -1109,8 +1106,8 @@ BogusCreate(tablePtr, key, newPtr) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ CONST char *key; /* Key to use to find or create matching * entry. */ - int *newPtr; /* Store info here telling whether a new - * entry was created. */ + int *newPtr; /* Store info here telling whether a new entry + * was created. */ { Tcl_Panic("called Tcl_CreateHashEntry on deleted table"); return NULL; @@ -1122,17 +1119,15 @@ BogusCreate(tablePtr, key, newPtr) * * RebuildTable -- * - * This procedure is invoked when the ratio of entries to hash - * buckets becomes too large. It creates a new table with a - * larger bucket array and moves all of the entries into the - * new table. + * This function is invoked when the ratio of entries to hash buckets + * becomes too large. It creates a new table with a larger bucket array + * and moves all of the entries into the new table. * * Results: * None. * * Side effects: - * Memory gets reallocated and entries get re-hashed to new - * buckets. + * Memory gets reallocated and entries get re-hashed to new buckets. * *---------------------------------------------------------------------- */ @@ -1166,8 +1161,8 @@ RebuildTable(tablePtr) oldBuckets = tablePtr->buckets; /* - * Allocate and initialize the new bucket array, and set up - * hashing constants for new array size. + * Allocate and initialize the new bucket array, and set up hashing + * constants for new array size. */ tablePtr->numBuckets *= 4; @@ -1236,3 +1231,11 @@ RebuildTable(tablePtr) } } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 77b1965..3733241 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -1,22 +1,22 @@ -/* +/* * tclIndexObj.c -- * - * This file implements objects of type "index". This object type - * is used to lookup a keyword in a table of valid values and cache - * the index of the matching entry. + * This file implements objects of type "index". This object type is used + * to lookup a keyword in a table of valid values and cache the index of + * the matching entry. * * Copyright (c) 1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIndexObj.c,v 1.24 2005/06/07 21:46:08 dgp Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.25 2005/07/21 14:38:49 dkf Exp $ */ #include "tclInt.h" /* - * Prototypes for procedures defined later in this file: + * Prototypes for functions defined later in this file: */ static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp, @@ -27,8 +27,8 @@ static void DupIndex _ANSI_ARGS_((Tcl_Obj *srcPtr, static void FreeIndex _ANSI_ARGS_((Tcl_Obj *objPtr)); /* - * The structure below defines the index Tcl object type by means of - * procedures that can be invoked by generic object code. + * The structure below defines the index Tcl object type by means of functions + * that can be invoked by generic object code. */ static Tcl_ObjType indexType = { @@ -40,9 +40,9 @@ static Tcl_ObjType indexType = { }; /* - * The definition of the internal representation of the "index" - * object; The internalRep.otherValuePtr field of an object of "index" - * type will be a pointer to one of these structures. + * The definition of the internal representation of the "index" object; The + * internalRep.otherValuePtr field of an object of "index" type will be a + * pointer to one of these structures. * * Keep this structure declaration in sync with tclTestObj.c */ @@ -62,31 +62,28 @@ typedef struct { (&(STRING_AT(table, offset, 1))) #define EXPAND_OF(indexRep) \ STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index) - /* *---------------------------------------------------------------------- * * Tcl_GetIndexFromObj -- * - * This procedure looks up an object's value in a table of strings - * and returns the index of the matching string, if any. + * This function looks up an object's value in a table of strings and + * returns the index of the matching string, if any. * * Results: - * - * If the value of objPtr is identical to or a unique abbreviation - * for one of the entries in objPtr, then the return value is - * TCL_OK and the index of the matching entry is stored at - * *indexPtr. If there isn't a proper match, then TCL_ERROR is - * returned and an error message is left in interp's result (unless - * interp is NULL). The msg argument is used in the error - * message; for example, if msg has the value "option" then the - * error message will say something flag 'bad option "foo": must be + * If the value of objPtr is identical to or a unique abbreviation for + * one of the entries in objPtr, then the return value is TCL_OK and the + * index of the matching entry is stored at *indexPtr. If there isn't a + * proper match, then TCL_ERROR is returned and an error message is left + * in interp's result (unless interp is NULL). The msg argument is used + * in the error message; for example, if msg has the value "option" then + * the error message will say something flag 'bad option "foo": must be * ...' * * Side effects: - * The result of the lookup is cached as the internal rep of - * objPtr, so that repeated lookups can be done quickly. + * The result of the lookup is cached as the internal rep of objPtr, so + * that repeated lookups can be done quickly. * *---------------------------------------------------------------------- */ @@ -98,24 +95,26 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) CONST char **tablePtr; /* Array of strings to compare against the * value of objPtr; last entry must be NULL * and there must not be duplicate entries. */ - CONST char *msg; /* Identifying word to use in error messages. */ + CONST char *msg; /* Identifying word to use in error + * messages. */ int flags; /* 0 or TCL_EXACT */ int *indexPtr; /* Place to store resulting integer index. */ { /* - * See if there is a valid cached result from a previous lookup - * (doing the check here saves the overhead of calling - * Tcl_GetIndexFromObjStruct in the common case where the result - * is cached). + * See if there is a valid cached result from a previous lookup (doing the + * check here saves the overhead of calling Tcl_GetIndexFromObjStruct in + * the common case where the result is cached). */ if (objPtr->typePtr == &indexType) { IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; + /* - * Here's hoping we don't get hit by unfortunate packing - * constraints on odd platforms like a Cray PVP... + * Here's hoping we don't get hit by unfortunate packing constraints + * on odd platforms like a Cray PVP... */ + if (indexRep->tablePtr == (VOID *)tablePtr && indexRep->offset == sizeof(char *)) { *indexPtr = indexRep->index; @@ -131,42 +130,40 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) * * Tcl_GetIndexFromObjStruct -- * - * This procedure looks up an object's value given a starting - * string and an offset for the amount of space between strings. - * This is useful when the strings are embedded in some other - * kind of array. + * This function looks up an object's value given a starting string and + * an offset for the amount of space between strings. This is useful when + * the strings are embedded in some other kind of array. * * Results: - * - * If the value of objPtr is identical to or a unique abbreviation - * for one of the entries in objPtr, then the return value is - * TCL_OK and the index of the matching entry is stored at - * *indexPtr. If there isn't a proper match, then TCL_ERROR is - * returned and an error message is left in interp's result (unless - * interp is NULL). The msg argument is used in the error - * message; for example, if msg has the value "option" then the - * error message will say something flag 'bad option "foo": must be + * If the value of objPtr is identical to or a unique abbreviation for + * one of the entries in objPtr, then the return value is TCL_OK and the + * index of the matching entry is stored at *indexPtr. If there isn't a + * proper match, then TCL_ERROR is returned and an error message is left + * in interp's result (unless interp is NULL). The msg argument is used + * in the error message; for example, if msg has the value "option" then + * the error message will say something flag 'bad option "foo": must be * ...' * * Side effects: - * The result of the lookup is cached as the internal rep of - * objPtr, so that repeated lookups can be done quickly. + * The result of the lookup is cached as the internal rep of objPtr, so + * that repeated lookups can be done quickly. * *---------------------------------------------------------------------- */ int -Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, +Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr; /* Object containing the string to lookup. */ CONST VOID *tablePtr; /* The first string in the table. The second * string will be at this address plus the * offset, the third plus the offset again, - * etc. The last entry must be NULL - * and there must not be duplicate entries. */ + * etc. The last entry must be NULL and there + * must not be duplicate entries. */ int offset; /* The number of bytes between entries */ - CONST char *msg; /* Identifying word to use in error messages. */ + CONST char *msg; /* Identifying word to use in error + * messages. */ int flags; /* 0 or TCL_EXACT */ int *indexPtr; /* Place to store resulting integer index. */ { @@ -201,18 +198,19 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, /* * The key should not be empty, otherwise it's not a match. */ - + if (key[0] == '\0') { goto error; } - + /* * Scan the table looking for one of: * - An exact match (always preferred) * - A single abbreviation (allowed depending on flags) * - Several abbreviations (never allowed, but overridden by exact match) */ - for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; + + for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr = NEXT_ENTRY(entryPtr, offset), i++) { for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) { if (*p1 == '\0') { @@ -222,30 +220,33 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, } if (*p1 == '\0') { /* - * The value is an abbreviation for this entry. Continue - * checking other entries to make sure it's unique. If we - * get more than one unique abbreviation, keep searching to - * see if there is an exact match, but remember the number - * of unique abbreviations and don't allow either. + * The value is an abbreviation for this entry. Continue checking + * other entries to make sure it's unique. If we get more than one + * unique abbreviation, keep searching to see if there is an exact + * match, but remember the number of unique abbreviations and + * don't allow either. */ numAbbrev++; index = i; } } + /* * Check if we were instructed to disallow abbreviations. */ + if ((flags & TCL_EXACT) || (numAbbrev != 1)) { goto error; } - done: + done: /* - * Cache the found representation. Note that we want to avoid - * allocating a new internal-rep if at all possible since that is - * potentially a slow operation. + * Cache the found representation. Note that we want to avoid allocating a + * new internal-rep if at all possible since that is potentially a slow + * operation. */ + if (objPtr->typePtr == &indexType) { indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; } else { @@ -261,18 +262,19 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, *indexPtr = index; return TCL_OK; - error: + error: if (interp != NULL) { /* * Produce a fancy error message. */ + int count; TclNewObj(resultPtr); Tcl_SetObjResult(interp, resultPtr); Tcl_AppendStringsToObj(resultPtr, - (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"", - key, "\": must be ", STRING_AT(tablePtr,offset,0), (char*)NULL); + (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"", key, + "\": must be ", STRING_AT(tablePtr,offset,0), (char*) NULL); for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0; *entryPtr != NULL; entryPtr = NEXT_ENTRY(entryPtr, offset), count++) { @@ -294,14 +296,14 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, * * SetIndexFromAny -- * - * This procedure is called to convert a Tcl object to index - * internal form. However, this doesn't make sense (need to have a - * table of keywords in order to do the conversion) so the - * procedure always generates an error. + * This function is called to convert a Tcl object to index internal + * form. However, this doesn't make sense (need to have a table of + * keywords in order to do the conversion) so the function always + * generates an error. * * Results: - * The return value is always TCL_ERROR, and an error message is - * left in interp's result if interp isn't NULL. + * The return value is always TCL_ERROR, and an error message is left in + * interp's result if interp isn't NULL. * * Side effects: * None. @@ -325,9 +327,8 @@ SetIndexFromAny(interp, objPtr) * * UpdateStringOfIndex -- * - * This procedure is called to convert a Tcl object from index - * internal form to its string form. No abbreviation is ever - * generated. + * This function is called to convert a Tcl object from index internal + * form to its string form. No abbreviation is ever generated. * * Results: * None. @@ -359,15 +360,15 @@ UpdateStringOfIndex(objPtr) * * DupIndex -- * - * This procedure is called to copy the internal rep of an index - * Tcl object from to another object. + * This function is called to copy the internal rep of an index Tcl + * object from to another object. * * Results: * None. * * Side effects: - * The internal representation of the target object is updated - * and the type is set. + * The internal representation of the target object is updated and the + * type is set. * *---------------------------------------------------------------------- */ @@ -389,8 +390,8 @@ DupIndex(srcPtr, dupPtr) * * FreeIndex -- * - * This procedure is called to delete the internal rep of an index - * Tcl object. + * This function is called to delete the internal rep of an index Tcl + * object. * * Results: * None. @@ -413,52 +414,77 @@ FreeIndex(objPtr) * * Tcl_WrongNumArgs -- * - * This procedure generates a "wrong # args" error message in an - * interpreter. It is used as a utility function by many command - * procedures. + * This function generates a "wrong # args" error message in an + * interpreter. It is used as a utility function by many command + * functions, including the function that implements procedures. * * Results: * None. * * Side effects: - * An error message is generated in interp's result object to - * indicate that a command was invoked with the wrong number of - * arguments. The message has the form + * An error message is generated in interp's result object to indicate + * that a command was invoked with the wrong number of arguments. The + * message has the form * wrong # args: should be "foo bar additional stuff" - * where "foo" and "bar" are the initial objects in objv (objc - * determines how many of these are printed) and "additional stuff" - * is the contents of the message argument. + * where "foo" and "bar" are the initial objects in objv (objc determines + * how many of these are printed) and "additional stuff" is the contents + * of the message argument. + * + * The message printed is modified somewhat if the command is wrapped + * inside an ensemble. In that case, the error message generated is + * rewritten in such a way that it appears to be generated from the + * user-visible command and not how that command is actually implemented, + * giving a better overall user experience. + * + * Internally, the Tcl core may set the flag INTERP_ALTERNATE_WRONG_ARGS + * in the interpreter to generate complex multi-part messages by calling + * this function repeatedly. This allows the code that knows how to + * handle ensemble-related error messages to be kept here while still + * generating suitable error messages for commands like [read] and + * [socket]. Ideally, this would be done through an extra flags argument, + * but that wouldn't be source-compatible with the existing API and it's + * a fairly rare requirement anyway. * *---------------------------------------------------------------------- */ void Tcl_WrongNumArgs(interp, objc, objv, message) - 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_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; register IndexRep *indexRep; Interp *iPtr = (Interp *) interp; 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 - * does error message generation for - * ensembles will still work. - * [Bug 1066837] */ -#define MAY_QUOTE_WORD (!isFirst) + 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 MAY_QUOTE_WORD 1 +# define AFTER_FIRST_WORD (void) 0 #endif /* AVOID_HACKS_FOR_ITCL */ TclNewObj(objPtr); @@ -470,70 +496,82 @@ Tcl_WrongNumArgs(interp, objc, objv, message) } /* - * Check to see if we are processing an ensemble implementation, - * and if so rewrite the results in terms of how the ensemble was - * invoked. + * 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 *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 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... + * We assume no object is of index type. */ - if (objc >= iPtr->ensembleRewrite.numInsertedObjs) { - objv += iPtr->ensembleRewrite.numInsertedObjs; - objc -= iPtr->ensembleRewrite.numInsertedObjs; + for (i=0 ; i<toPrint ; i++) { /* - * We assume no object is of index type. + * Add the element, quoting it if necessary. */ - for (i=0 ; i<iPtr->ensembleRewrite.numRemovedObjs ; i++) { - /* - * Add the element, quoting it if necessary. - */ - - elementStr = Tcl_GetStringFromObj( - iPtr->ensembleRewrite.sourceObjs[i], &elemLen); - len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); - if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = ckalloc((unsigned) len); - len = Tcl_ConvertCountedElement(elementStr, elemLen, - quotedElementStr, flags); - Tcl_AppendToObj(objPtr, quotedElementStr, len); - ckfree(quotedElementStr); - } else { - Tcl_AppendToObj(objPtr, elementStr, elemLen); - } -#ifndef AVOID_HACKS_FOR_ITCL - isFirst = 0; -#endif /* AVOID_HACKS_FOR_ITCL */ - /* - * Add a space if the word is not the last one (which - * has a moderately complex condition here). - */ + elementStr = Tcl_GetStringFromObj(origObjv[i], &elemLen); + len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); + + if (MAY_QUOTE_WORD && len != elemLen) { + char *quotedElementStr = ckalloc((unsigned) len); + + len = Tcl_ConvertCountedElement(elementStr, elemLen, + quotedElementStr, flags); + Tcl_AppendToObj(objPtr, quotedElementStr, len); + ckfree(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 < (iPtr->ensembleRewrite.numRemovedObjs - 1)) - || objc || message) { - Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); - } + if (i<toPrint-1 || objc!=0 || message!=NULL) { + Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); } } } /* - * Now add the arguments (other than those rewritten) that the - * caller took from its calling context. + * 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 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) { indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL); @@ -544,8 +582,10 @@ Tcl_WrongNumArgs(interp, objc, objv, message) elementStr = Tcl_GetStringFromObj(objv[i], &elemLen); len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); + if (MAY_QUOTE_WORD && len != elemLen) { char *quotedElementStr = ckalloc((unsigned) len); + len = Tcl_ConvertCountedElement(elementStr, elemLen, quotedElementStr, flags); Tcl_AppendToObj(objPtr, quotedElementStr, len); @@ -554,29 +594,38 @@ Tcl_WrongNumArgs(interp, objc, objv, message) Tcl_AppendToObj(objPtr, elementStr, elemLen); } } -#ifndef AVOID_HACKS_FOR_ITCL - isFirst = 0; -#endif /* AVOID_HACKS_FOR_ITCL */ + + 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) { + + if (i<objc-1 || message!=NULL) { Tcl_AppendStringsToObj(objPtr, " ", (char *) 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. + * 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) { + if (message != NULL) { Tcl_AppendStringsToObj(objPtr, message, (char *) NULL); } Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL); Tcl_SetObjResult(interp, objPtr); #undef MAY_QUOTE_WORD +#undef AFTER_FIRST_WORD } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclMain.c b/generic/tclMain.c index fc373bc..f2954b6 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -1,4 +1,4 @@ -/* +/* * tclMain.c -- * * Main program for Tcl shells and other Tcl-based applications. @@ -7,21 +7,27 @@ * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 2000 Ajuba Solutions. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMain.c,v 1.30 2004/11/13 00:19:10 dgp Exp $ + * RCS: @(#) $Id: tclMain.c,v 1.31 2005/07/21 14:38:49 dkf Exp $ */ #include "tclInt.h" -# undef TCL_STORAGE_CLASS -# define TCL_STORAGE_CLASS DLLEXPORT +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + +/* + * The default prompt used when the user has not overridden it. + */ + +#define DEFAULT_PRIMARY_PROMPT "% " /* - * Declarations for various library procedures and variables (don't want - * to include tclPort.h here, because people might copy this file out of - * the Tcl source directory to make their own modified versions). + * Declarations for various library procedures and variables (don't want to + * include tclPort.h here, because people might copy this file out of the Tcl + * source directory to make their own modified versions). */ extern DLLIMPORT int isatty _ANSI_ARGS_((int fd)); @@ -31,26 +37,26 @@ static Tcl_Obj *tclStartupScriptEncoding = NULL; static Tcl_MainLoopProc *mainLoopProc = NULL; -/* - * Structure definition for information used to keep the state of - * an interactive command processor that reads lines from standard - * input and writes prompts and results to standard output. +/* + * Structure definition for information used to keep the state of an + * interactive command processor that reads lines from standard input and + * writes prompts and results to standard output. */ typedef enum { - PROMPT_NONE, /* Print no prompt */ - PROMPT_START, /* Print prompt for command start */ - PROMPT_CONTINUE /* Print prompt for command continuation */ + PROMPT_NONE, /* Print no prompt */ + PROMPT_START, /* Print prompt for command start */ + PROMPT_CONTINUE /* Print prompt for command continuation */ } PromptType; typedef struct InteractiveState { - Tcl_Channel input; /* The standard input channel from which - * lines are read. */ - int tty; /* Non-zero means standard input is a - * terminal-like device. Zero means it's - * a file. */ - Tcl_Obj *commandPtr; /* Used to assemble lines of input into - * Tcl commands. */ + Tcl_Channel input; /* The standard input channel from which lines + * are read. */ + int tty; /* Non-zero means standard input is a + * terminal-like device. Zero means it's a + * file. */ + Tcl_Obj *commandPtr; /* Used to assemble lines of input into Tcl + * commands. */ PromptType prompt; /* Next prompt to print */ Tcl_Interp *interp; /* Interpreter that evaluates interactive * commands. */ @@ -64,24 +70,25 @@ static void Prompt _ANSI_ARGS_((Tcl_Interp *interp, PromptType *promptPtr)); static void StdinProc _ANSI_ARGS_((ClientData clientData, int mask)); - /* *---------------------------------------------------------------------- * * Tcl_SetStartupScript -- * - * Sets the path and encoding of the startup script to be evaluated - * by Tcl_Main, used to override the command line processing. + * Sets the path and encoding of the startup script to be evaluated by + * Tcl_Main, used to override the command line processing. * * Results: - * None. + * None. * * Side effects: * *---------------------------------------------------------------------- */ -void Tcl_SetStartupScript(path, encoding) + +void +Tcl_SetStartupScript(path, encoding) Tcl_Obj *path; /* Filesystem path of startup script file */ CONST char *encoding; /* Encoding of the data in that file */ { @@ -106,30 +113,31 @@ void Tcl_SetStartupScript(path, encoding) Tcl_IncrRefCount(tclStartupScriptEncoding); } } - /* *---------------------------------------------------------------------- * * Tcl_GetStartupScript -- * - * Gets the path and encoding of the startup script to be evaluated - * by Tcl_Main. + * Gets the path and encoding of the startup script to be evaluated by + * Tcl_Main. * * Results: * The path of the startup script; NULL if none has been set. * * Side effects: - * If encodingPtr is not NULL, stores a (CONST char *) in it - * pointing to the encoding name registered for the startup - * script. Tcl retains ownership of the string, and may free - * it. Caller should make a copy for long-term use. + * If encodingPtr is not NULL, stores a (CONST char *) in it pointing to + * the encoding name registered for the startup script. Tcl retains + * ownership of the string, and may free it. Caller should make a copy + * for long-term use. * *---------------------------------------------------------------------- */ -Tcl_Obj *Tcl_GetStartupScript(encodingPtr) - CONST char** encodingPtr; /* When not NULL, points to storage for - * the (CONST char *) that points to the + +Tcl_Obj * +Tcl_GetStartupScript(encodingPtr) + CONST char **encodingPtr; /* When not NULL, points to storage for the + * (CONST char *) that points to the * registered encoding name for the startup * script */ { @@ -142,37 +150,39 @@ Tcl_Obj *Tcl_GetStartupScript(encodingPtr) } return tclStartupScriptPath; } - + /* *---------------------------------------------------------------------- * * TclSetStartupScriptPath -- * - * Primes the startup script VFS path, used to override the - * command line processing. + * Primes the startup script VFS path, used to override the command line + * processing. * * Results: - * None. + * None. * * Side effects: - * This procedure initializes the VFS path of the Tcl script to - * run at startup. + * This procedure initializes the VFS path of the Tcl script to run at + * startup. * *---------------------------------------------------------------------- */ -void TclSetStartupScriptPath(path) + +void +TclSetStartupScriptPath(path) Tcl_Obj *path; { Tcl_SetStartupScript(path, NULL); } - + /* *---------------------------------------------------------------------- * * TclGetStartupScriptPath -- * - * Gets the startup script VFS path, used to override the - * command line processing. + * Gets the startup script VFS path, used to override the command line + * processing. * * Results: * The startup script VFS path, NULL if none has been set. @@ -182,43 +192,46 @@ void TclSetStartupScriptPath(path) * *---------------------------------------------------------------------- */ -Tcl_Obj *TclGetStartupScriptPath() + +Tcl_Obj * +TclGetStartupScriptPath() { return Tcl_GetStartupScript(NULL); } - + /* *---------------------------------------------------------------------- * * TclSetStartupScriptFileName -- * - * Primes the startup script file name, used to override the - * command line processing. + * Primes the startup script file name, used to override the command line + * processing. * * Results: - * None. + * None. * * Side effects: - * This procedure initializes the file name of the Tcl script to - * run at startup. + * This procedure initializes the file name of the Tcl script to run at + * startup. * *---------------------------------------------------------------------- */ -void TclSetStartupScriptFileName(fileName) + +void +TclSetStartupScriptFileName(fileName) CONST char *fileName; { Tcl_Obj *path = Tcl_NewStringObj(fileName,-1); Tcl_SetStartupScript(path, NULL); } - /* *---------------------------------------------------------------------- * * TclGetStartupScriptFileName -- * - * Gets the startup script file name, used to override the - * command line processing. + * Gets the startup script file name, used to override the command line + * processing. * * Results: * The startup script file name, NULL if none has been set. @@ -228,7 +241,9 @@ void TclSetStartupScriptFileName(fileName) * *---------------------------------------------------------------------- */ -CONST char *TclGetStartupScriptFileName() + +CONST char * +TclGetStartupScriptFileName() { Tcl_Obj *path = Tcl_GetStartupScript(NULL); @@ -241,45 +256,46 @@ CONST char *TclGetStartupScriptFileName() /*---------------------------------------------------------------------- * * Tcl_SourceRCFile -- - * - * This procedure is typically invoked by Tcl_Main of Tk_Main - * procedure to source an application specific rc file into the - * interpreter at startup time. - * + * + * This procedure is typically invoked by Tcl_Main of Tk_Main procedure + * to source an application specific rc file into the interpreter at + * startup time. + * * Results: - * None. + * None. * * Side effects: - * Depends on what's in the rc script. + * Depends on what's in the rc script. * *---------------------------------------------------------------------- */ - + void Tcl_SourceRCFile(interp) - Tcl_Interp *interp; /* Interpreter to source rc file into. */ + Tcl_Interp *interp; /* Interpreter to source rc file into. */ { - Tcl_DString temp; + Tcl_DString temp; CONST char *fileName; Tcl_Channel errChannel; fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); - if (fileName != NULL) { - Tcl_Channel c; - CONST char *fullName; + if (fileName != NULL) { + Tcl_Channel c; + CONST char *fullName; Tcl_DStringInit(&temp); fullName = Tcl_TranslateFileName(interp, fileName, &temp); - if (fullName == NULL) { + if (fullName == NULL) { /* - * Couldn't translate the file name (e.g. it referred to a - * bogus user or there was no HOME environment variable). - * Just do nothing. + * Couldn't translate the file name (e.g. it referred to a bogus + * user or there was no HOME environment variable). Just do + * nothing. */ } else { - /* - * Test for the existence of the rc file before trying to read it. + /* + * Test for the existence of the rc file before trying to read it. */ + c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); if (c != (Tcl_Channel) NULL) { Tcl_Close(NULL, c); @@ -303,13 +319,13 @@ Tcl_SourceRCFile(interp) * Main program for tclsh and most other Tcl-based applications. * * Results: - * None. This procedure never returns (it exits the process when - * it's done). + * None. This procedure never returns (it exits the process when it's + * done). * * Side effects: - * This procedure initializes the Tcl world and then starts - * interpreting commands; almost anything could happen, depending - * on the script being interpreted. + * This procedure initializes the Tcl world and then starts interpreting + * commands; almost anything could happen, depending on the script being + * interpreted. * *---------------------------------------------------------------------- */ @@ -320,9 +336,8 @@ Tcl_Main(argc, argv, appInitProc) char **argv; /* Array of argument strings. */ Tcl_AppInitProc *appInitProc; /* Application-specific initialization - * procedure to call after most - * initialization but before starting to - * execute commands. */ + * procedure to call after most initialization + * but before starting to execute commands. */ { Tcl_Obj *path; Tcl_Obj *resultPtr; @@ -342,14 +357,14 @@ Tcl_Main(argc, argv, appInitProc) Tcl_InitMemory(interp); /* - * 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 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 @@ -369,11 +384,11 @@ Tcl_Main(argc, argv, appInitProc) } /* - * The CONST casting is safe, and better we do it here than force - * all callers of Tcl_Main to do it. (Those callers are likely - * in a main() that can't easily change its signature.) + * The CONST casting is safe, and better we do it here than force all + * callers of Tcl_Main to do it. (Those callers are likely in a main() + * that can't easily change its signature.) */ - + args = Tcl_Merge(argc-1, (CONST char **)argv+1); Tcl_ExternalToUtfDString(NULL, args, -1, &argString); Tcl_SetVar(interp, "argv", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY); @@ -401,7 +416,7 @@ Tcl_Main(argc, argv, appInitProc) tty = isatty(0); Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); - + /* * Invoke application-specific initialization. */ @@ -424,9 +439,8 @@ Tcl_Main(argc, argv, appInitProc) } /* - * If a script file was specified then just source that file - * and quit. Must fetch it again, as the appInitProc might - * have reset it. + * If a script file was specified then just source that file and quit. + * Must fetch it again, as the appInitProc might have reset it. */ path = Tcl_GetStartupScript(&encodingName); @@ -455,8 +469,8 @@ Tcl_Main(argc, argv, appInitProc) Tcl_DStringFree(&argString); /* - * We're running interactively. Source a user-specific startup - * file if the application specified one and if the file exists. + * We're running interactively. Source a user-specific startup file if the + * application specified one and if the file exists. */ Tcl_SourceRCFile(interp); @@ -465,9 +479,9 @@ Tcl_Main(argc, argv, appInitProc) } /* - * 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. + * 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. */ commandPtr = Tcl_NewObj(); @@ -476,6 +490,7 @@ Tcl_Main(argc, argv, appInitProc) /* * Get a new value for tty if anyone writes to ::tcl_interactive */ + Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); @@ -490,7 +505,7 @@ Tcl_Main(argc, argv, appInitProc) } inChannel = Tcl_GetStdChannel(TCL_STDIN); if (inChannel == (Tcl_Channel) NULL) { - break; + break; } } if (Tcl_IsShared(commandPtr)) { @@ -498,23 +513,21 @@ Tcl_Main(argc, argv, appInitProc) commandPtr = Tcl_DuplicateObj(commandPtr); Tcl_IncrRefCount(commandPtr); } - length = Tcl_GetsObj(inChannel, commandPtr); + length = Tcl_GetsObj(inChannel, commandPtr); if (length < 0) { if (Tcl_InputBlocked(inChannel)) { - /* - * 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 + * 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 */ @@ -559,21 +572,21 @@ Tcl_Main(argc, argv, appInitProc) } Tcl_DecrRefCount(resultPtr); } - if (mainLoopProc != NULL) { + if (mainLoopProc != NULL) { /* - * If a main loop has been defined while running interactively, - * we want to start a fileevent based prompt by establishing a + * 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. */ InteractiveState *isPtr = NULL; if (inChannel) { - if (tty) { + if (tty) { Prompt(interp, &prompt); - } - isPtr = (InteractiveState *) + } + isPtr = (InteractiveState *) ckalloc((int) sizeof(InteractiveState)); isPtr->input = inChannel; isPtr->tty = tty; @@ -612,8 +625,8 @@ Tcl_Main(argc, argv, appInitProc) #ifdef TCL_MEM_DEBUG /* - * This code here only for the (unsupported and deprecated) - * [checkmem] command. + * This code here only for the (unsupported and deprecated) [checkmem] + * command. */ if (tclMemDumpFileName != NULL) { @@ -623,14 +636,13 @@ Tcl_Main(argc, argv, appInitProc) #endif } - done: + done: if ((exitCode == 0) && (mainLoopProc != NULL) && !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. + * 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)(); @@ -641,9 +653,9 @@ Tcl_Main(argc, argv, appInitProc) } /* - * 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_Eval call should never return. + * 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_Eval call should never return. */ if (!Tcl_InterpDeleted(interp)) { @@ -654,22 +666,22 @@ Tcl_Main(argc, argv, appInitProc) Tcl_Eval(interp, buffer); } - /* - * If Tcl_Eval 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. - */ + /* + * If Tcl_Eval 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. + */ - if (!Tcl_InterpDeleted(interp)) { - Tcl_DeleteInterp(interp); - } + if (!Tcl_InterpDeleted(interp)) { + Tcl_DeleteInterp(interp); + } } Tcl_SetStartupScript(NULL, NULL); /* - * If we get here, the master interp has been deleted. Allow - * its destruction with the last matching Tcl_Release. + * If we get here, the master interp has been deleted. Allow its + * destruction with the last matching Tcl_Release. */ Tcl_Release((ClientData) interp); @@ -687,8 +699,8 @@ Tcl_Main(argc, argv, appInitProc) * Returns the previously defined main loop procedure. * * Side effects: - * This procedure will be called before Tcl exits, allowing for - * the creation of an event loop. + * This procedure will be called before Tcl exits, allowing for the + * creation of an event loop. * *--------------------------------------------------------------- */ @@ -705,17 +717,16 @@ Tcl_SetMainLoop(proc) * * StdinProc -- * - * This procedure is invoked by the event dispatcher whenever - * standard input becomes readable. It grabs the next line of - * input characters, adds them to a command being assembled, and - * executes the command if it's complete. + * This procedure is invoked by the event dispatcher whenever standard + * input becomes readable. It grabs the next line of input characters, + * adds them to a command being assembled, and executes the command if + * it's complete. * * Results: * None. * * Side effects: - * Could be almost arbitrary, depending on the command that's - * typed. + * Could be almost arbitrary, depending on the command that's typed. * *---------------------------------------------------------------------- */ @@ -723,8 +734,8 @@ Tcl_SetMainLoop(proc) /* ARGSUSED */ static void StdinProc(clientData, mask) - ClientData clientData; /* The state of interactive cmd line */ - int mask; /* Not used. */ + ClientData clientData; /* The state of interactive cmd line */ + int mask; /* Not used. */ { InteractiveState *isPtr = (InteractiveState *) clientData; Tcl_Channel chan = isPtr->input; @@ -744,10 +755,11 @@ StdinProc(clientData, mask) } 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. + * 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, (ClientData) isPtr); @@ -761,17 +773,16 @@ StdinProc(clientData, mask) Tcl_IncrRefCount(commandPtr); } Tcl_AppendToObj(commandPtr, "\n", 1); - isPtr->prompt = PROMPT_CONTINUE; - goto prompt; + isPtr->prompt = PROMPT_CONTINUE; + goto prompt; } isPtr->prompt = PROMPT_START; /* * 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. + * 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, (ClientData) isPtr); @@ -806,7 +817,7 @@ StdinProc(clientData, mask) * If a tty stdin is still around, output a prompt. */ - prompt: + prompt: if (isPtr->tty && (isPtr->input != (Tcl_Channel) NULL)) { Prompt(interp, &(isPtr->prompt)); isPtr->input = Tcl_GetStdChannel(TCL_STDIN); @@ -818,25 +829,24 @@ StdinProc(clientData, mask) * * Prompt -- * - * Issue a prompt on standard output, or invoke a script - * to issue the prompt. + * Issue a prompt on standard output, or invoke a script to issue the + * prompt. * * Results: * None. * * Side effects: - * A prompt gets output, and a Tcl script may be evaluated - * in interp. + * A prompt gets output, and a Tcl script may be evaluated in interp. * *---------------------------------------------------------------------- */ static void Prompt(interp, promptPtr) - Tcl_Interp *interp; /* Interpreter to use for prompting. */ - PromptType *promptPtr; /* Points to type of prompt to print. - * Filled with PROMPT_NONE after a - * prompt is printed. */ + Tcl_Interp *interp; /* Interpreter to use for prompting. */ + PromptType *promptPtr; /* Points to type of prompt to print. Filled + * with PROMPT_NONE after a prompt is + * printed. */ { Tcl_Obj *promptCmdPtr; int code; @@ -849,15 +859,17 @@ Prompt(interp, promptPtr) promptCmdPtr = Tcl_GetVar2Ex(interp, ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"), NULL, TCL_GLOBAL_ONLY); + if (Tcl_InterpDeleted(interp)) { return; } if (promptCmdPtr == NULL) { - defaultPrompt: + defaultPrompt: outChannel = Tcl_GetStdChannel(TCL_STDOUT); if ((*promptPtr == PROMPT_START) && (outChannel != (Tcl_Channel) NULL)) { - Tcl_WriteChars(outChannel, "% ", 2); + Tcl_WriteChars(outChannel, DEFAULT_PRIMARY_PROMPT, + strlen(DEFAULT_PRIMARY_PROMPT)); } } else { code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL); @@ -865,16 +877,25 @@ Prompt(interp, promptPtr) Tcl_AddErrorInfo(interp, "\n (script that generates prompt)"); errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel != (Tcl_Channel) NULL) { - Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); - } + if (errChannel != (Tcl_Channel) NULL) { + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); + } goto defaultPrompt; } } + outChannel = Tcl_GetStdChannel(TCL_STDOUT); if (outChannel != (Tcl_Channel) NULL) { Tcl_Flush(outChannel); } *promptPtr = PROMPT_NONE; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclNotify.c b/generic/tclNotify.c index d025c2c..cb777af 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -1,20 +1,20 @@ -/* +/* * tclNotify.c -- * - * This file implements the generic portion of the Tcl notifier. - * The notifier is lowest-level part of the event system. It - * manages an event queue that holds Tcl_Event structures. The - * platform specific portion of the notifier is defined in the - * tcl*Notify.c files in each platform directory. + * This file implements the generic portion of the Tcl notifier. The + * notifier is lowest-level part of the event system. It manages an event + * queue that holds Tcl_Event structures. The platform specific portion + * of the notifier is defined in the tcl*Notify.c files in each platform + * directory. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNotify.c,v 1.18 2005/05/10 18:34:46 kennykb Exp $ + * RCS: @(#) $Id: tclNotify.c,v 1.19 2005/07/21 14:38:50 dkf Exp $ */ #include "tclInt.h" @@ -22,8 +22,8 @@ extern TclStubs tclStubs; /* - * For each event source (created with Tcl_CreateEventSource) there - * is a structure of the following type: + * For each event source (created with Tcl_CreateEventSource) there is a + * structure of the following type: */ typedef struct EventSource { @@ -36,34 +36,34 @@ typedef struct EventSource { /* * The following structure keeps track of the state of the notifier on a * per-thread basis. The first three elements keep track of the event queue. - * In addition to the first (next to be serviced) and last events in the queue, - * we keep track of a "marker" event. This provides a simple priority + * In addition to the first (next to be serviced) and last events in the + * queue, we keep track of a "marker" event. This provides a simple priority * mechanism whereby events can be inserted at the front of the queue but - * behind all other high-priority events already in the queue (this is used for - * things like a sequence of Enter and Leave events generated during a grab in - * Tk). These elements are protected by the queueMutex so that any thread - * can queue an event on any notifier. Note that all of the values in this - * structure will be initialized to 0. + * behind all other high-priority events already in the queue (this is used + * for things like a sequence of Enter and Leave events generated during a + * grab in Tk). These elements are protected by the queueMutex so that any + * thread can queue an event on any notifier. Note that all of the values in + * this structure will be initialized to 0. */ typedef struct ThreadSpecificData { Tcl_Event *firstEventPtr; /* First pending event, or NULL if none. */ Tcl_Event *lastEventPtr; /* Last pending event, or NULL if none. */ - Tcl_Event *markerEventPtr; /* Last high-priority event in queue, or - * NULL if none. */ + Tcl_Event *markerEventPtr; /* Last high-priority event in queue, or NULL + * if none. */ Tcl_Mutex queueMutex; /* Mutex to protect access to the previous * three fields. */ int serviceMode; /* One of TCL_SERVICE_NONE or * TCL_SERVICE_ALL. */ - int blockTimeSet; /* 0 means there is no maximum block - * time: block forever. */ - Tcl_Time blockTime; /* If blockTimeSet is 1, gives the - * maximum elapsed time for the next block. */ - int inTraversal; /* 1 if Tcl_SetMaxBlockTime is being - * called during an event source traversal. */ + int blockTimeSet; /* 0 means there is no maximum block time: + * block forever. */ + Tcl_Time blockTime; /* If blockTimeSet is 1, gives the maximum + * elapsed time for the next block. */ + int inTraversal; /* 1 if Tcl_SetMaxBlockTime is being called + * during an event source traversal. */ EventSource *firstEventSourcePtr; - /* Pointer to first event source in - * list of event sources for this thread. */ + /* Pointer to first event source in list of + * event sources for this thread. */ Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */ ClientData clientData; /* Opaque handle for platform specific * notifier. */ @@ -77,9 +77,9 @@ typedef struct ThreadSpecificData { static Tcl_ThreadDataKey dataKey; /* - * Global list of notifiers. Access to this list is controlled by the - * listLock mutex. If this becomes a performance bottleneck, this could - * be replaced with a hashtable. + * Global list of notifiers. Access to this list is controlled by the listLock + * mutex. If this becomes a performance bottleneck, this could be replaced + * with a hashtable. */ static ThreadSpecificData *firstNotifierPtr = NULL; @@ -117,11 +117,15 @@ TclInitNotifier() Tcl_MutexLock(&listLock); for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId; - tsdPtr = tsdPtr->nextPtr) { + tsdPtr = tsdPtr->nextPtr) { /* Empty loop body. */ } + if (NULL == tsdPtr) { - /* Notifier not yet initialized in this thread */ + /* + * Notifier not yet initialized in this thread. + */ + tsdPtr = TCL_TSD_INIT(&dataKey); tsdPtr->threadId = threadId; tsdPtr->clientData = tclStubs.tcl_InitNotifier(); @@ -137,23 +141,22 @@ TclInitNotifier() * * TclFinalizeNotifier -- * - * Finalize the thread local data structures for the notifier - * subsystem. + * Finalize the thread local data structures for the notifier subsystem. * * Results: - * None. + * None. * * Side effects: - * Removes the notifier associated with the current thread from - * the global notifier list. This is done only if the notifier - * was initialized for this thread by call to TclInitNotifier(). - * This is always true for threads which have been seeded with - * an Tcl interpreter, since the call to Tcl_CreateInterp will, - * among other things, call TclInitializeSubsystems() and this - * one will, in turn, call the TclInitNotifier() for the thread. - * For threads created without the Tcl interpreter, though, - * nobody is explicitly nor implicitly calling the TclInitNotifier - * hence, TclFinalizeNotifier should not be performed at all. + * Removes the notifier associated with the current thread from the + * global notifier list. This is done only if the notifier was + * initialized for this thread by call to TclInitNotifier(). This is + * always true for threads which have been seeded with an Tcl + * interpreter, since the call to Tcl_CreateInterp will, among other + * things, call TclInitializeSubsystems() and this one will, in turn, + * call the TclInitNotifier() for the thread. For threads created without + * the Tcl interpreter, though, nobody is explicitly nor implicitly + * calling the TclInitNotifier hence, TclFinalizeNotifier should not be + * performed at all. * *---------------------------------------------------------------------- */ @@ -166,7 +169,7 @@ TclFinalizeNotifier() Tcl_Event *evPtr, *hold; if (!tsdPtr->initialized) { - return; /* Notifier not initialized for the current thread */ + return; /* Notifier not initialized for the current thread */ } Tcl_MutexLock(&(tsdPtr->queueMutex)); @@ -186,7 +189,7 @@ TclFinalizeNotifier() } Tcl_MutexFinalize(&(tsdPtr->queueMutex)); for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL; - prevPtrPtr = &((*prevPtrPtr)->nextPtr)) { + prevPtrPtr = &((*prevPtrPtr)->nextPtr)) { if (*prevPtrPtr == tsdPtr) { *prevPtrPtr = tsdPtr->nextPtr; break; @@ -202,17 +205,17 @@ TclFinalizeNotifier() * * Tcl_SetNotifier -- * - * Install a set of alternate functions for use with the notifier. - # In particular, this can be used to install the Xt-based - * notifier for use with the Browser plugin. + * Install a set of alternate functions for use with the notifier. In + * particular, this can be used to install the Xt-based notifier for use + * with the Browser plugin. * * Results: * None. * * Side effects: - * Overstomps part of the stub vector. This relies on hooks - * added to the default procedures in case those are called - * directly (i.e., not through the stub table.) + * Overstomps part of the stub vector. This relies on hooks added to the + * default functions in case those are called directly (i.e., not through + * the stub table.) * *---------------------------------------------------------------------- */ @@ -238,10 +241,9 @@ Tcl_SetNotifier(notifierProcPtr) * * Tcl_CreateEventSource -- * - * This procedure is invoked to create a new source of events. - * The source is identified by a procedure that gets invoked - * during Tcl_DoOneEvent to check for events on that source - * and queue them. + * This function is invoked to create a new source of events. The source + * is identified by a function that gets invoked during Tcl_DoOneEvent to + * check for events on that source and queue them. * * * Results: @@ -249,34 +251,36 @@ Tcl_SetNotifier(notifierProcPtr) * * Side effects: * SetupProc and checkProc will be invoked each time that Tcl_DoOneEvent - * runs out of things to do. SetupProc will be invoked before - * Tcl_DoOneEvent calls select or whatever else it uses to wait - * for events. SetupProc typically calls functions like - * Tcl_SetMaxBlockTime to indicate what to wait for. + * runs out of things to do. SetupProc will be invoked before + * Tcl_DoOneEvent calls select or whatever else it uses to wait for + * events. SetupProc typically calls functions like Tcl_SetMaxBlockTime + * to indicate what to wait for. * * CheckProc is called after select or whatever operation was actually - * used to wait. It figures out whether anything interesting actually + * used to wait. It figures out whether anything interesting actually * happened (e.g. by calling Tcl_AsyncReady), and then calls * Tcl_QueueEvent to queue any events that are ready. * - * Each of these procedures is passed two arguments, e.g. + * Each of these functions is passed two arguments, e.g. * (*checkProc)(ClientData clientData, int flags)); - * ClientData is the same as the clientData argument here, and flags - * is a combination of things like TCL_FILE_EVENTS that indicates - * what events are of interest: setupProc and checkProc use flags - * to figure out whether their events are relevant or not. + * ClientData is the same as the clientData argument here, and flags is a + * combination of things like TCL_FILE_EVENTS that indicates what events + * are of interest: setupProc and checkProc use flags to figure out + * whether their events are relevant or not. * *---------------------------------------------------------------------- */ void Tcl_CreateEventSource(setupProc, checkProc, clientData) - Tcl_EventSetupProc *setupProc; /* Procedure to invoke to figure out - * what to wait for. */ - Tcl_EventCheckProc *checkProc; /* Procedure to call after waiting - * to see what happened. */ - ClientData clientData; /* One-word argument to pass to - * setupProc and checkProc. */ + Tcl_EventSetupProc *setupProc; + /* Function to invoke to figure out what to + * wait for. */ + Tcl_EventCheckProc *checkProc; + /* Function to call after waiting to see what + * happened. */ + ClientData clientData; /* One-word argument to pass to setupProc and + * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource)); @@ -293,28 +297,29 @@ Tcl_CreateEventSource(setupProc, checkProc, clientData) * * Tcl_DeleteEventSource -- * - * This procedure is invoked to delete the source of events - * given by proc and clientData. + * This function is invoked to delete the source of events given by proc + * and clientData. * * Results: * None. * * Side effects: - * The given event source is cancelled, so its procedure will - * never again be called. If no such source exists, nothing - * happens. + * The given event source is cancelled, so its function will never again + * be called. If no such source exists, nothing happens. * *---------------------------------------------------------------------- */ void Tcl_DeleteEventSource(setupProc, checkProc, clientData) - Tcl_EventSetupProc *setupProc; /* Procedure to invoke to figure out - * what to wait for. */ - Tcl_EventCheckProc *checkProc; /* Procedure to call after waiting - * to see what happened. */ - ClientData clientData; /* One-word argument to pass to - * setupProc and checkProc. */ + Tcl_EventSetupProc *setupProc; + /* Function to invoke to figure out what to + * wait for. */ + Tcl_EventCheckProc *checkProc; + /* Function to call after waiting to see what + * happened. */ + ClientData clientData; /* One-word argument to pass to setupProc and + * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); EventSource *sourcePtr, *prevPtr; @@ -342,8 +347,7 @@ Tcl_DeleteEventSource(setupProc, checkProc, clientData) * * Tcl_QueueEvent -- * - * Queue an event on the event queue associated with the - * current thread. + * Queue an event on the event queue associated with the current thread. * * Results: * None. @@ -356,12 +360,11 @@ Tcl_DeleteEventSource(setupProc, checkProc, clientData) void Tcl_QueueEvent(evPtr, position) - Tcl_Event* evPtr; /* Event to add to queue. The storage - * space must have been allocated the caller - * with malloc (ckalloc), and it becomes - * the property of the event queue. It - * will be freed after the event has been - * handled. */ + Tcl_Event* evPtr; /* Event to add to queue. The storage space + * must have been allocated the caller with + * malloc (ckalloc), and it becomes the + * property of the event queue. It will be + * freed after the event has been handled. */ Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, * TCL_QUEUE_MARK. */ { @@ -388,12 +391,11 @@ Tcl_QueueEvent(evPtr, position) void Tcl_ThreadQueueEvent(threadId, evPtr, position) Tcl_ThreadId threadId; /* Identifier for thread to use. */ - Tcl_Event* evPtr; /* Event to add to queue. The storage - * space must have been allocated the caller - * with malloc (ckalloc), and it becomes - * the property of the event queue. It - * will be freed after the event has been - * handled. */ + Tcl_Event* evPtr; /* Event to add to queue. The storage space + * must have been allocated the caller with + * malloc (ckalloc), and it becomes the + * property of the event queue. It will be + * freed after the event has been handled. */ Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, * TCL_QUEUE_MARK. */ { @@ -405,7 +407,7 @@ Tcl_ThreadQueueEvent(threadId, evPtr, position) Tcl_MutexLock(&listLock); for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId; - tsdPtr = tsdPtr->nextPtr) { + tsdPtr = tsdPtr->nextPtr) { /* Empty loop body. */ } @@ -424,12 +426,12 @@ Tcl_ThreadQueueEvent(threadId, evPtr, position) * * QueueEvent -- * - * Insert an event into the specified thread's event queue at one - * of three positions: the head, the tail, or before a floating - * marker. Events inserted before the marker will be processed in - * first-in-first-out order, but before any events inserted at - * the tail of the queue. Events inserted at the head of the - * queue will be processed in last-in-first-out order. + * Insert an event into the specified thread's event queue at one of + * three positions: the head, the tail, or before a floating marker. + * Events inserted before the marker will be processed in first-in- + * first-out order, but before any events inserted at the tail of the + * queue. Events inserted at the head of the queue will be processed in + * last-in-first-out order. * * Results: * None. @@ -444,12 +446,11 @@ static void QueueEvent(tsdPtr, evPtr, position) ThreadSpecificData *tsdPtr; /* Handle to thread local data that indicates * which event queue to use. */ - Tcl_Event* evPtr; /* Event to add to queue. The storage - * space must have been allocated the caller - * with malloc (ckalloc), and it becomes - * the property of the event queue. It - * will be freed after the event has been - * handled. */ + Tcl_Event* evPtr; /* Event to add to queue. The storage space + * must have been allocated the caller with + * malloc (ckalloc), and it becomes the + * property of the event queue. It will be + * freed after the event has been handled. */ Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, * TCL_QUEUE_MARK. */ { @@ -474,12 +475,12 @@ QueueEvent(tsdPtr, evPtr, position) evPtr->nextPtr = tsdPtr->firstEventPtr; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->lastEventPtr = evPtr; - } + } tsdPtr->firstEventPtr = evPtr; } else if (position == TCL_QUEUE_MARK) { /* - * Insert the event after the current marker event and advance - * the marker to the new event. + * Insert the event after the current marker event and advance the + * marker to the new event. */ if (tsdPtr->markerEventPtr == NULL) { @@ -502,10 +503,10 @@ QueueEvent(tsdPtr, evPtr, position) * * Tcl_DeleteEvents -- * - * Calls a procedure for each event in the queue and deletes those - * for which the procedure returns 1. Events for which the - * procedure returns 0 are left in the queue. Operates on the - * queue associated with the current thread. + * Calls a function for each event in the queue and deletes those for + * which the function returns 1. Events for which the function returns 0 + * are left in the queue. Operates on the queue associated with the + * current thread. * * Results: * None. @@ -518,35 +519,34 @@ QueueEvent(tsdPtr, evPtr, position) void Tcl_DeleteEvents(proc, clientData) - Tcl_EventDeleteProc *proc; /* The procedure to call. */ - ClientData clientData; /* type-specific data. */ + Tcl_EventDeleteProc *proc; /* The function to call. */ + ClientData clientData; /* The type-specific data. */ { Tcl_Event *evPtr, *prevPtr, *hold; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_MutexLock(&(tsdPtr->queueMutex)); for (prevPtr = (Tcl_Event *) NULL, evPtr = tsdPtr->firstEventPtr; - evPtr != (Tcl_Event *) NULL; - ) { - if ((*proc) (evPtr, clientData) == 1) { - if (tsdPtr->firstEventPtr == evPtr) { - tsdPtr->firstEventPtr = evPtr->nextPtr; - } else { - prevPtr->nextPtr = evPtr->nextPtr; - } - if (evPtr->nextPtr == (Tcl_Event *) NULL) { - tsdPtr->lastEventPtr = prevPtr; - } - if (tsdPtr->markerEventPtr == evPtr) { - tsdPtr->markerEventPtr = prevPtr; - } - hold = evPtr; - evPtr = evPtr->nextPtr; - ckfree((char *) hold); - } else { - prevPtr = evPtr; - evPtr = evPtr->nextPtr; - } + evPtr != (Tcl_Event *) NULL; /*EMPTY STEP*/) { + if ((*proc) (evPtr, clientData) == 1) { + if (tsdPtr->firstEventPtr == evPtr) { + tsdPtr->firstEventPtr = evPtr->nextPtr; + } else { + prevPtr->nextPtr = evPtr->nextPtr; + } + if (evPtr->nextPtr == (Tcl_Event *) NULL) { + tsdPtr->lastEventPtr = prevPtr; + } + if (tsdPtr->markerEventPtr == evPtr) { + tsdPtr->markerEventPtr = prevPtr; + } + hold = evPtr; + evPtr = evPtr->nextPtr; + ckfree((char *) hold); + } else { + prevPtr = evPtr; + evPtr = evPtr->nextPtr; + } } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); } @@ -556,18 +556,17 @@ Tcl_DeleteEvents(proc, clientData) * * Tcl_ServiceEvent -- * - * Process one event from the event queue, or invoke an - * asynchronous event handler. Operates on event queue for - * current thread. + * Process one event from the event queue, or invoke an asynchronous + * event handler. Operates on event queue for current thread. * * Results: - * The return value is 1 if the procedure actually found an event - * to process. If no processing occurred, then 0 is returned. + * The return value is 1 if the function actually found an event to + * process. If no processing occurred, then 0 is returned. * * Side effects: - * Invokes all of the event handlers for the highest priority - * event in the event queue. May collapse some events into a - * single event or discard stale events. + * Invokes all of the event handlers for the highest priority event in + * the event queue. May collapse some events into a single event or + * discard stale events. * *---------------------------------------------------------------------- */ @@ -577,9 +576,9 @@ Tcl_ServiceEvent(flags) int flags; /* Indicates what events should be processed. * May be any combination of TCL_WINDOW_EVENTS * TCL_FILE_EVENTS, TCL_TIMER_EVENTS, or other - * flags defined elsewhere. Events not - * matching this will be skipped for processing - * later. */ + * flags defined elsewhere. Events not + * matching this will be skipped for + * processing later. */ { Tcl_Event *evPtr, *prevPtr; Tcl_EventProc *proc; @@ -587,11 +586,11 @@ Tcl_ServiceEvent(flags) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * Asynchronous event handlers are considered to be the highest - * priority events, and so must be invoked before we process events - * on the event queue. + * Asynchronous event handlers are considered to be the highest priority + * events, and so must be invoked before we process events on the event + * queue. */ - + if (Tcl_AsyncReady()) { (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); return 1; @@ -600,33 +599,33 @@ Tcl_ServiceEvent(flags) /* * No event flags is equivalent to TCL_ALL_EVENTS. */ - + if ((flags & TCL_ALL_EVENTS) == 0) { flags |= TCL_ALL_EVENTS; } /* - * Loop through all the events in the queue until we find one - * that can actually be handled. + * Loop through all the events in the queue until we find one that can + * actually be handled. */ Tcl_MutexLock(&(tsdPtr->queueMutex)); for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; - evPtr = evPtr->nextPtr) { + evPtr = evPtr->nextPtr) { /* - * Call the handler for the event. If it actually handles the - * event then free the storage for the event. There are two - * tricky things here, both stemming from the fact that the event - * code may be re-entered while servicing the event: + * Call the handler for the event. If it actually handles the event + * then free the storage for the event. There are two tricky things + * here, both stemming from the fact that the event code may be + * re-entered while servicing the event: * * 1. Set the "proc" field to NULL. This is a signal to ourselves - * that we shouldn't reexecute the handler if the event loop - * is re-entered. + * that we shouldn't reexecute the handler if the event loop is + * re-entered. * 2. When freeing the event, must search the queue again from the - * front to find it. This is because the event queue could - * change almost arbitrarily while handling the event, so we - * can't depend on pointers found now still being valid when - * the handler returns. + * front to find it. This is because the event queue could change + * almost arbitrarily while handling the event, so we can't depend + * on pointers found now still being valid when the handler + * returns. */ proc = evPtr->proc; @@ -636,10 +635,10 @@ Tcl_ServiceEvent(flags) evPtr->proc = NULL; /* - * Release the lock before calling the event procedure. This - * allows other threads to post events if we enter a recursive - * event loop in this thread. Note that we are making the assumption - * that if the proc returns 0, the event is still in the list. + * Release the lock before calling the event function. This allows + * other threads to post events if we enter a recursive event loop in + * this thread. Note that we are making the assumption that if the + * proc returns 0, the event is still in the list. */ Tcl_MutexUnlock(&(tsdPtr->queueMutex)); @@ -661,8 +660,8 @@ Tcl_ServiceEvent(flags) } } else { for (prevPtr = tsdPtr->firstEventPtr; - prevPtr && prevPtr->nextPtr != evPtr; - prevPtr = prevPtr->nextPtr) { + prevPtr && prevPtr->nextPtr != evPtr; + prevPtr = prevPtr->nextPtr) { /* Empty loop body. */ } if (prevPtr) { @@ -684,8 +683,8 @@ Tcl_ServiceEvent(flags) return 1; } else { /* - * The event wasn't actually handled, so we have to restore - * the proc field to allow the event to be attempted again. + * The event wasn't actually handled, so we have to restore the + * proc field to allow the event to be attempted again. */ evPtr->proc = proc; @@ -730,7 +729,7 @@ Tcl_GetServiceMode() * Returns the previous service mode. * * Side effects: - * Invokes the notifier service mode hook procedure. + * Invokes the notifier service mode hook function. * *---------------------------------------------------------------------- */ @@ -756,10 +755,10 @@ Tcl_SetServiceMode(mode) * * Tcl_SetMaxBlockTime -- * - * This procedure is invoked by event sources to tell the notifier - * how long it may block the next time it blocks. The timePtr - * argument gives a maximum time; the actual time may be less if - * some other event source requested a smaller time. + * This function is invoked by event sources to tell the notifier how + * long it may block the next time it blocks. The timePtr argument gives + * a maximum time; the actual time may be less if some other event source + * requested a smaller time. * * Results: * None. @@ -772,9 +771,9 @@ Tcl_SetServiceMode(mode) void Tcl_SetMaxBlockTime(timePtr) - Tcl_Time *timePtr; /* Specifies a maximum elapsed time for - * the next blocking operation in the - * event tsdPtr-> */ + Tcl_Time *timePtr; /* Specifies a maximum elapsed time for the + * next blocking operation in the event + * tsdPtr-> */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -786,8 +785,8 @@ Tcl_SetMaxBlockTime(timePtr) } /* - * If we are called outside an event source traversal, set the - * timeout immediately. + * If we are called outside an event source traversal, set the timeout + * immediately. */ if (!tsdPtr->inTraversal) { @@ -804,27 +803,27 @@ Tcl_SetMaxBlockTime(timePtr) * * Tcl_DoOneEvent -- * - * Process a single event of some sort. If there's no work to - * do, wait for an event to occur, then process it. + * Process a single event of some sort. If there's no work to do, wait + * for an event to occur, then process it. * * Results: - * The return value is 1 if the procedure actually found an event - * to process. If no processing occurred, then 0 is returned (this - * can happen if the TCL_DONT_WAIT flag is set or if there are no - * event handlers to wait for in the set specified by flags). + * The return value is 1 if the function actually found an event to + * process. If no processing occurred, then 0 is returned (this can + * happen if the TCL_DONT_WAIT flag is set or if there are no event + * handlers to wait for in the set specified by flags). * * Side effects: - * May delay execution of process while waiting for an event, - * unless TCL_DONT_WAIT is set in the flags argument. Event - * sources are invoked to check for and queue events. Event - * handlers may produce arbitrary side effects. + * May delay execution of process while waiting for an event, unless + * TCL_DONT_WAIT is set in the flags argument. Event sources are invoked + * to check for and queue events. Event handlers may produce arbitrary + * side effects. * *---------------------------------------------------------------------- */ int Tcl_DoOneEvent(flags) - int flags; /* Miscellaneous flag values: may be any + int flags; /* Miscellaneous flag values: may be any * combination of TCL_DONT_WAIT, * TCL_WINDOW_EVENTS, TCL_FILE_EVENTS, * TCL_TIMER_EVENTS, TCL_IDLE_EVENTS, or @@ -836,8 +835,7 @@ Tcl_DoOneEvent(flags) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * The first thing we do is to service any asynchronous event - * handlers. + * The first thing we do is to service any asynchronous event handlers. */ if (Tcl_AsyncReady()) { @@ -854,29 +852,28 @@ Tcl_DoOneEvent(flags) } /* - * Set the service mode to none so notifier event routines won't - * try to service events recursively. + * Set the service mode to none so notifier event routines won't try to + * service events recursively. */ oldMode = tsdPtr->serviceMode; tsdPtr->serviceMode = TCL_SERVICE_NONE; /* - * The core of this procedure is an infinite loop, even though - * we only service one event. The reason for this is that we - * may be processing events that don't do anything inside of Tcl. + * The core of this function is an infinite loop, even though we only + * service one event. The reason for this is that we may be processing + * events that don't do anything inside of Tcl. */ while (1) { - /* - * If idle events are the only things to service, skip the - * main part of the loop and go directly to handle idle - * events (i.e. don't wait even if TCL_DONT_WAIT isn't set). + * If idle events are the only things to service, skip the main part + * of the loop and go directly to handle idle events (i.e. don't wait + * even if TCL_DONT_WAIT isn't set). */ if ((flags & TCL_ALL_EVENTS) == TCL_IDLE_EVENTS) { - flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; + flags = TCL_IDLE_EVENTS | TCL_DONT_WAIT; goto idleEvents; } @@ -890,8 +887,8 @@ Tcl_DoOneEvent(flags) } /* - * If TCL_DONT_WAIT is set, be sure to poll rather than - * blocking, otherwise reset the block time to infinity. + * If TCL_DONT_WAIT is set, be sure to poll rather than blocking, + * otherwise reset the block time to infinity. */ if (flags & TCL_DONT_WAIT) { @@ -903,13 +900,13 @@ Tcl_DoOneEvent(flags) } /* - * Set up all the event sources for new events. This will - * cause the block time to be updated if necessary. + * Set up all the event sources for new events. This will cause the + * block time to be updated if necessary. */ tsdPtr->inTraversal = 1; for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; - sourcePtr = sourcePtr->nextPtr) { + sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->setupProc) { (sourcePtr->setupProc)(sourcePtr->clientData, flags); } @@ -923,8 +920,8 @@ Tcl_DoOneEvent(flags) } /* - * Wait for a new event or a timeout. If Tcl_WaitForEvent - * returns -1, we should abort Tcl_DoOneEvent. + * Wait for a new event or a timeout. If Tcl_WaitForEvent returns -1, + * we should abort Tcl_DoOneEvent. */ result = Tcl_WaitForEvent(timePtr); @@ -938,7 +935,7 @@ Tcl_DoOneEvent(flags) */ for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; - sourcePtr = sourcePtr->nextPtr) { + sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->checkProc) { (sourcePtr->checkProc)(sourcePtr->clientData, flags); } @@ -954,12 +951,12 @@ Tcl_DoOneEvent(flags) } /* - * We've tried everything at this point, but nobody we know - * about had anything to do. Check for idle events. If none, - * either quit or go back to the top and try again. + * We've tried everything at this point, but nobody we know about had + * anything to do. Check for idle events. If none, either quit or go + * back to the top and try again. */ - idleEvents: + idleEvents: if (flags & TCL_IDLE_EVENTS) { if (TclServiceIdle()) { result = 1; @@ -971,23 +968,21 @@ Tcl_DoOneEvent(flags) } /* - * If Tcl_WaitForEvent has returned 1, - * indicating that one system event has been dispatched - * (and thus that some Tcl code might have been indirectly executed), - * we break out of the loop. - * We do this to give VwaitCmd for instance a chance to check - * if that system event had the side effect of changing the - * variable (so the vwait can return and unwind properly). + * If Tcl_WaitForEvent has returned 1, indicating that one system + * event has been dispatched (and thus that some Tcl code might have + * been indirectly executed), we break out of the loop. We do this to + * give VwaitCmd for instance a chance to check if that system event + * had the side effect of changing the variable (so the vwait can + * return and unwind properly). * - * NB: We will process idle events if any first, because - * otherwise we might never do the idle events if the notifier - * always gets system events. + * NB: We will process idle events if any first, because otherwise we + * might never do the idle events if the notifier always gets + * system events. */ if (result) { break; } - } tsdPtr->serviceMode = oldMode; @@ -999,12 +994,11 @@ Tcl_DoOneEvent(flags) * * Tcl_ServiceAll -- * - * This routine checks all of the event sources, processes - * events that are on the Tcl event queue, and then calls the - * any idle handlers. Platform specific notifier callbacks that - * generate events should call this routine before returning to - * the system in order to ensure that Tcl gets a chance to - * process the new events. + * This routine checks all of the event sources, processes events that + * are on the Tcl event queue, and then calls the any idle handlers. + * Platform specific notifier callbacks that generate events should call + * this routine before returning to the system in order to ensure that + * Tcl gets a chance to process the new events. * * Results: * Returns 1 if an event or idle handler was invoked, else 0. @@ -1027,10 +1021,10 @@ Tcl_ServiceAll() } /* - * We need to turn off event servicing like we to in Tcl_DoOneEvent, - * to avoid recursive calls. + * We need to turn off event servicing like we to in Tcl_DoOneEvent, to + * avoid recursive calls. */ - + tsdPtr->serviceMode = TCL_SERVICE_NONE; /* @@ -1042,22 +1036,22 @@ Tcl_ServiceAll() } /* - * Make a single pass through all event sources, queued events, - * and idle handlers. Note that we wait to update the notifier - * timer until the end so we can avoid multiple changes. + * Make a single pass through all event sources, queued events, and idle + * handlers. Note that we wait to update the notifier timer until the end + * so we can avoid multiple changes. */ tsdPtr->inTraversal = 1; tsdPtr->blockTimeSet = 0; for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; - sourcePtr = sourcePtr->nextPtr) { + sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->setupProc) { (sourcePtr->setupProc)(sourcePtr->clientData, TCL_ALL_EVENTS); } } for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; - sourcePtr = sourcePtr->nextPtr) { + sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->checkProc) { (sourcePtr->checkProc)(sourcePtr->clientData, TCL_ALL_EVENTS); } @@ -1085,8 +1079,8 @@ Tcl_ServiceAll() * * Tcl_ThreadAlert -- * - * This function wakes up the notifier associated with the - * specified thread (if there is one). + * This function wakes up the notifier associated with the specified + * thread (if there is one). * * Results: * None. @@ -1104,10 +1098,9 @@ Tcl_ThreadAlert(threadId) ThreadSpecificData *tsdPtr; /* - * Find the notifier associated with the specified thread. - * Note that we need to hold the listLock while calling - * Tcl_AlertNotifier to avoid a race condition where - * the specified thread might destroy its notifier. + * Find the notifier associated with the specified thread. Note that we + * need to hold the listLock while calling Tcl_AlertNotifier to avoid a + * race condition where the specified thread might destroy its notifier. */ Tcl_MutexLock(&listLock); @@ -1121,3 +1114,11 @@ Tcl_ThreadAlert(threadId) } Tcl_MutexUnlock(&listLock); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclParse.c b/generic/tclParse.c index fbf1d65..53b2021 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1,58 +1,56 @@ -/* +/* * tclParse.c -- * - * This file contains procedures that parse Tcl scripts. They - * do so in a general-purpose fashion that can be used for many - * different purposes, including compilation, direct execution, - * code analysis, etc. + * This file contains functions that parse Tcl scripts. They do so in a + * general-purpose fashion that can be used for many different purposes, + * including compilation, direct execution, code analysis, etc. * * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Ajuba Solutions. * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParse.c,v 1.42 2005/05/10 18:34:46 kennykb Exp $ + * RCS: @(#) $Id: tclParse.c,v 1.43 2005/07/21 14:38:50 dkf Exp $ */ #include "tclInt.h" /* - * The following table provides parsing information about each possible - * 8-bit character. The table is designed to be referenced with either - * signed or unsigned characters, so it has 384 entries. The first 128 - * entries correspond to negative character values, the next 256 correspond - * to positive character values. The last 128 entries are identical to the - * first 128. The table is always indexed with a 128-byte offset (the 128th - * entry corresponds to a character value of 0). - * - * The macro CHAR_TYPE is used to index into the table and return - * information about its character argument. The following return - * values are defined. - * - * TYPE_NORMAL - All characters that don't have special significance - * to the Tcl parser. - * TYPE_SPACE - The character is a whitespace character other - * than newline. - * TYPE_COMMAND_END - Character is newline or semicolon. - * TYPE_SUBS - Character begins a substitution or has other - * special meaning in ParseTokens: backslash, dollar - * sign, or open bracket. - * TYPE_QUOTE - Character is a double quote. - * TYPE_CLOSE_PAREN - Character is a right parenthesis. - * TYPE_CLOSE_BRACK - Character is a right square bracket. - * TYPE_BRACE - Character is a curly brace (either left or right). + * The following table provides parsing information about each possible 8-bit + * character. The table is designed to be referenced with either signed or + * unsigned characters, so it has 384 entries. The first 128 entries + * correspond to negative character values, the next 256 correspond to + * positive character values. The last 128 entries are identical to the first + * 128. The table is always indexed with a 128-byte offset (the 128th entry + * corresponds to a character value of 0). + * + * The macro CHAR_TYPE is used to index into the table and return information + * about its character argument. The following return values are defined. + * + * TYPE_NORMAL - All characters that don't have special significance to + * the Tcl parser. + * TYPE_SPACE - The character is a whitespace character other than + * newline. + * TYPE_COMMAND_END - Character is newline or semicolon. + * TYPE_SUBS - Character begins a substitution or has other special + * meaning in ParseTokens: backslash, dollar sign, or + * open bracket. + * TYPE_QUOTE - Character is a double quote. + * TYPE_CLOSE_PAREN - Character is a right parenthesis. + * TYPE_CLOSE_BRACK - Character is a right square bracket. + * TYPE_BRACE - Character is a curly brace (either left or right). */ -#define TYPE_NORMAL 0 -#define TYPE_SPACE 0x1 -#define TYPE_COMMAND_END 0x2 -#define TYPE_SUBS 0x4 -#define TYPE_QUOTE 0x8 -#define TYPE_CLOSE_PAREN 0x10 -#define TYPE_CLOSE_BRACK 0x20 -#define TYPE_BRACE 0x40 +#define TYPE_NORMAL 0 +#define TYPE_SPACE 0x1 +#define TYPE_COMMAND_END 0x2 +#define TYPE_SUBS 0x4 +#define TYPE_QUOTE 0x8 +#define TYPE_CLOSE_PAREN 0x10 +#define TYPE_CLOSE_BRACK 0x20 +#define TYPE_BRACE 0x40 #define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)] @@ -170,16 +168,16 @@ static CONST char charTypeTable[] = { }; /* - * Prototypes for local procedures defined in this file: + * Prototypes for local functions defined in this file: */ static int CommandComplete _ANSI_ARGS_((CONST char *script, int numBytes)); -static int ParseComment _ANSI_ARGS_((CONST char *src, int numBytes, - Tcl_Parse *parsePtr)); +static int ParseComment _ANSI_ARGS_((CONST char *src, + int numBytes, Tcl_Parse *parsePtr)); static int ParseTokens _ANSI_ARGS_((CONST char *src, int numBytes, int mask, int flags, Tcl_Parse *parsePtr)); - + /* *---------------------------------------------------------------------- * @@ -200,9 +198,9 @@ void TclParseInit(interp, string, numBytes, parsePtr) Tcl_Interp *interp; /* Interpreter to use for error reporting */ CONST char *string; /* String to be parsed. */ - int numBytes; /* Total number of bytes in string. If < 0, - * the script consists of all bytes up to - * the first null character. */ + int numBytes; /* Total number of bytes in string. If < 0, + * the script consists of all bytes up to the + * first null character. */ Tcl_Parse *parsePtr; /* Points to struct to initialize */ { parsePtr->numWords = 0; @@ -216,63 +214,59 @@ TclParseInit(interp, string, numBytes, parsePtr) parsePtr->incomplete = 0; parsePtr->errorType = TCL_PARSE_SUCCESS; } + /* *---------------------------------------------------------------------- * * Tcl_ParseCommand -- * - * Given a string, this procedure parses the first Tcl command - * in the string and returns information about the structure of - * the command. + * Given a string, this function parses the first Tcl command in the + * string and returns information about the structure of the command. * * Results: - * The return value is TCL_OK if the command was parsed - * successfully and TCL_ERROR otherwise. If an error occurs - * and interp isn't NULL then an error message is left in - * its result. On a successful return, parsePtr is filled in - * with information about the command that was parsed. + * The return value is TCL_OK if the command was parsed successfully and + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an + * error message is left in its result. On a successful return, parsePtr + * is filled in with information about the command that was parsed. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the command, then additional space is - * malloc-ed. If the procedure returns TCL_OK then the caller must - * eventually invoke Tcl_FreeParse to release any additional space - * that was allocated. + * If there is insufficient space in parsePtr to hold all the information + * about the command, then additional space is malloc-ed. If the function + * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to + * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int Tcl_ParseCommand(interp, start, numBytes, nested, parsePtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting; - * if NULL, then no error message is - * provided. */ - CONST char *start; /* First character of string containing - * one or more Tcl commands. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting; if + * NULL, then no error message is provided. */ + CONST char *start; /* First character of string containing one or + * more Tcl commands. */ register int numBytes; /* Total number of bytes in string. If < 0, - * the script consists of all bytes up to - * the first null character. */ + * the script consists of all bytes up to the + * first null character. */ int nested; /* Non-zero means this is a nested command: - * close bracket should be considered - * a command terminator. If zero, then close + * close bracket should be considered a + * command terminator. If zero, then close * bracket has no special meaning. */ register Tcl_Parse *parsePtr; - /* Structure to fill in with information - * about the parsed command; any previous - * information in the structure is - * ignored. */ + /* Structure to fill in with information about + * the parsed command; any previous + * information in the structure is ignored. */ { - register CONST char *src; /* Points to current character - * in the command. */ + register CONST char *src; /* Points to current character in the + * command. */ char type; /* Result returned by CHAR_TYPE(*src). */ Tcl_Token *tokenPtr; /* Pointer to token being filled in. */ int wordIndex; /* Index of word token for current word. */ - int terminators; /* CHAR_TYPE bits that indicate the end - * of a command. */ + int terminators; /* CHAR_TYPE bits that indicate the end of a + * command. */ CONST char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to * point to char after terminating one. */ int scanned; - + if ((start == NULL) && (numBytes>0)) { if (interp != NULL) { Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC); @@ -299,7 +293,8 @@ Tcl_ParseCommand(interp, start, numBytes, nested, parsePtr) */ scanned = ParseComment(start, numBytes, parsePtr); - src = (start + scanned); numBytes -= scanned; + src = (start + scanned); + numBytes -= scanned; if (numBytes == 0) { if (nested) { parsePtr->incomplete = nested; @@ -307,8 +302,8 @@ Tcl_ParseCommand(interp, start, numBytes, nested, parsePtr) } /* - * The following loop parses the words of the command, one word - * in each iteration through the loop. + * The following loop parses the words of the command, one word in each + * iteration through the loop. */ parsePtr->commandStart = src; @@ -332,7 +327,8 @@ Tcl_ParseCommand(interp, start, numBytes, nested, parsePtr) */ scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type); - src += scanned; numBytes -= scanned; + src += scanned; + numBytes -= scanned; if (numBytes == 0) { parsePtr->term = src; break; @@ -348,17 +344,18 @@ Tcl_ParseCommand(interp, start, numBytes, nested, parsePtr) /* * At this point the word can have one of four forms: something - * enclosed in quotes, something enclosed in braces, and - * expanding word, or an unquoted word (anything else). + * enclosed in quotes, something enclosed in braces, and expanding + * word, or an unquoted word (anything else). */ -parseWord: + parseWord: if (*src == '"') { if (Tcl_ParseQuotedString(interp, src, numBytes, parsePtr, 1, &termPtr) != TCL_OK) { goto error; } - src = termPtr; numBytes = parsePtr->end - src; + src = termPtr; + numBytes = parsePtr->end - src; } else if (*src == '{') { static char expPfx[] = "expand"; CONST size_t expPfxLen = sizeof(expPfx) - 1; @@ -369,15 +366,15 @@ parseWord: parsePtr, 1, &termPtr) != TCL_OK) { goto error; } - src = termPtr; numBytes = parsePtr->end - src; + src = termPtr; + numBytes = parsePtr->end - src; - /* - * Check whether the braces contained - * the word expansion prefix. + /* + * Check whether the braces contained the word expansion prefix. */ expPtr = &parsePtr->tokenPtr[expIdx]; - if ( (expPfxLen == (size_t) expPtr->size) + if ((expPfxLen == (size_t) expPtr->size) /* Same length as prefix */ && (0 == expandWord) /* Haven't seen prefix already */ @@ -397,21 +394,21 @@ parseWord: } } else { /* - * This is an unquoted word. Call ParseTokens and let it do - * all of the work. + * This is an unquoted word. Call ParseTokens and let it do all of + * the work. */ if (ParseTokens(src, numBytes, TYPE_SPACE|terminators, TCL_SUBST_ALL, parsePtr) != TCL_OK) { goto error; } - src = parsePtr->term; numBytes = parsePtr->end - src; + src = parsePtr->term; + numBytes = parsePtr->end - src; } /* - * Finish filling in the token for the word and check for the - * special case of a word consisting of a single range of - * literal text. + * Finish filling in the token for the word and check for the special + * case of a word consisting of a single range of literal text. */ tokenPtr = &parsePtr->tokenPtr[wordIndex]; @@ -426,15 +423,15 @@ parseWord: } /* - * Do two additional checks: (a) make sure we're really at the - * end of a word (there might have been garbage left after a - * quoted or braced word), and (b) check for the end of the - * command. + * Do two additional checks: (a) make sure we're really at the end of + * a word (there might have been garbage left after a quoted or braced + * word), and (b) check for the end of the command. */ scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type); if (scanned) { - src += scanned; numBytes -= scanned; + src += scanned; + numBytes -= scanned; continue; } @@ -444,10 +441,10 @@ parseWord: } if ((type & terminators) != 0) { parsePtr->term = src; - src++; + src++; break; } - if (src[-1] == '"') { + if (src[-1] == '"') { if (interp != NULL) { Tcl_SetResult(interp, "extra characters after close-quote", TCL_STATIC); @@ -467,48 +464,49 @@ parseWord: parsePtr->commandSize = src - parsePtr->commandStart; return TCL_OK; - error: + error: Tcl_FreeParse(parsePtr); parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; return TCL_ERROR; } - + /* *---------------------------------------------------------------------- * * TclParseWhiteSpace -- * - * Scans up to numBytes bytes starting at src, consuming white - * space as defined by Tcl's parsing rules. + * Scans up to numBytes bytes starting at src, consuming white space as + * defined by Tcl's parsing rules. * * Results: - * Returns the number of bytes recognized as white space. Records - * at parsePtr, information about the parse. Records at typePtr - * the character type of the non-whitespace character that terminated - * the scan. + * Returns the number of bytes recognized as white space. Records at + * parsePtr, information about the parse. Records at typePtr the + * character type of the non-whitespace character that terminated the + * scan. * * Side effects: * None. * *---------------------------------------------------------------------- */ + int TclParseWhiteSpace(src, numBytes, parsePtr, typePtr) CONST char *src; /* First character to parse. */ register int numBytes; /* Max number of bytes to scan. */ Tcl_Parse *parsePtr; /* Information about parse in progress. - * Updated if parsing indicates - * an incomplete command. */ - char *typePtr; /* Points to location to store character - * type of character that ends run - * of whitespace */ + * Updated if parsing indicates an incomplete + * command. */ + char *typePtr; /* Points to location to store character type + * of character that ends run of whitespace */ { register char type = TYPE_NORMAL; register CONST char *p = src; while (1) { while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) { - numBytes--; p++; + numBytes--; + p++; } if (numBytes && (type & TYPE_SUBS)) { if (*p != '\\') { @@ -538,31 +536,30 @@ TclParseWhiteSpace(src, numBytes, parsePtr, typePtr) * * TclParseHex -- * - * Scans a hexadecimal number as a Tcl_UniChar value. - * (e.g., for parsing \x and \u escape sequences). - * At most numBytes bytes are scanned. + * Scans a hexadecimal number as a Tcl_UniChar value (e.g., for parsing + * \x and \u escape sequences). At most numBytes bytes are scanned. * * Results: - * The numeric value is stored in *resultPtr. - * Returns the number of bytes consumed. + * The numeric value is stored in *resultPtr. Returns the number of bytes + * consumed. * * Notes: - * Relies on the following properties of the ASCII - * character set, with which UTF-8 is compatible: + * Relies on the following properties of the ASCII character set, with + * which UTF-8 is compatible: * - * The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z' - * occupy consecutive code points, and '0' < 'A' < 'a'. + * The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z' occupy + * consecutive code points, and '0' < 'A' < 'a'. * *---------------------------------------------------------------------- */ + int TclParseHex(src, numBytes, resultPtr) CONST char *src; /* First character to parse. */ int numBytes; /* Max number of byes to scan */ - Tcl_UniChar *resultPtr; /* Points to storage provided by - * caller where the Tcl_UniChar - * resulting from the conversion is - * to be written. */ + Tcl_UniChar *resultPtr; /* Points to storage provided by caller where + * the Tcl_UniChar resulting from the + * conversion is to be written. */ { Tcl_UniChar result = 0; register CONST char *p = src; @@ -595,33 +592,33 @@ TclParseHex(src, numBytes, resultPtr) * * TclParseBackslash -- * - * Scans up to numBytes bytes starting at src, consuming a - * backslash sequence as defined by Tcl's parsing rules. + * Scans up to numBytes bytes starting at src, consuming a backslash + * sequence as defined by Tcl's parsing rules. * * Results: * Records at readPtr the number of bytes making up the backslash - * sequence. Records at dst the UTF-8 encoded equivalent of - * that backslash sequence. Returns the number of bytes written - * to dst, at most TCL_UTF_MAX. Either readPtr or dst may be - * NULL, if the results are not needed, but the return value is - * the same either way. + * sequence. Records at dst the UTF-8 encoded equivalent of that + * backslash sequence. Returns the number of bytes written to dst, at + * most TCL_UTF_MAX. Either readPtr or dst may be NULL, if the results + * are not needed, but the return value is the same either way. * * Side effects: * None. * *---------------------------------------------------------------------- */ + int TclParseBackslash(src, numBytes, readPtr, dst) - CONST char * src; /* Points to the backslash character of a - * a backslash sequence */ - int numBytes; /* Max number of bytes to scan */ - int *readPtr; /* NULL, or points to storage where the - * number of bytes scanned should be written. */ - char *dst; /* NULL, or points to buffer where the UTF-8 - * encoding of the backslash sequence is to be - * written. At most TCL_UTF_MAX bytes will be - * written there. */ + CONST char *src; /* Points to the backslash character of a a + * backslash sequence. */ + int numBytes; /* Max number of bytes to scan. */ + int *readPtr; /* NULL, or points to storage where the number + * of bytes scanned should be written. */ + char *dst; /* NULL, or points to buffer where the UTF-8 + * encoding of the backslash sequence is to be + * written. At most TCL_UTF_MAX bytes will be + * written there. */ { register CONST char *p = src+1; Tcl_UniChar result; @@ -636,11 +633,14 @@ TclParseBackslash(src, numBytes, readPtr, dst) } if (dst == NULL) { - dst = buf; + dst = buf; } if (numBytes == 1) { - /* Can only scan the backslash. Return it. */ + /* + * Can only scan the backslash, so return it. + */ + result = '\\'; count = 1; goto done; @@ -648,105 +648,117 @@ TclParseBackslash(src, numBytes, readPtr, dst) count = 2; switch (*p) { - /* - * Note: in the conversions below, use absolute values (e.g., - * 0xa) rather than symbolic values (e.g. \n) that get converted - * by the compiler. It's possible that compilers on some - * platforms will do the symbolic conversions differently, which - * could result in non-portable Tcl scripts. - */ - - case 'a': - result = 0x7; - break; - case 'b': - result = 0x8; - break; - case 'f': - result = 0xc; - break; - case 'n': - result = 0xa; - break; - case 'r': - result = 0xd; - break; - case 't': - result = 0x9; - break; - case 'v': - result = 0xb; - break; - case 'x': - count += TclParseHex(p+1, numBytes-1, &result); - if (count == 2) { - /* No hexadigits -> This is just "x". */ - result = 'x'; - } else { - /* Keep only the last byte (2 hex digits) */ - result = (unsigned char) result; - } - break; - case 'u': - count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-1, &result); - if (count == 2) { - /* No hexadigits -> This is just "u". */ - result = 'u'; + /* + * Note: in the conversions below, use absolute values (e.g., 0xa) + * rather than symbolic values (e.g. \n) that get converted by the + * compiler. It's possible that compilers on some platforms will do + * the symbolic conversions differently, which could result in + * non-portable Tcl scripts. + */ + + case 'a': + result = 0x7; + break; + case 'b': + result = 0x8; + break; + case 'f': + result = 0xc; + break; + case 'n': + result = 0xa; + break; + case 'r': + result = 0xd; + break; + case 't': + result = 0x9; + break; + case 'v': + result = 0xb; + break; + case 'x': + count += TclParseHex(p+1, numBytes-1, &result); + if (count == 2) { + /* + * No hexadigits -> This is just "x". + */ + + result = 'x'; + } else { + /* + * Keep only the last byte (2 hex digits). + */ + result = (unsigned char) result; + } + break; + case 'u': + count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-1, &result); + if (count == 2) { + /* + * No hexadigits -> This is just "u". + */ + result = 'u'; + } + break; + case '\n': + count--; + do { + p++; + count++; + } while ((count < numBytes) && ((*p == ' ') || (*p == '\t'))); + result = ' '; + break; + case 0: + result = '\\'; + count = 1; + break; + default: + /* + * Check for an octal number \oo?o? + */ + + if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */ + result = (unsigned char)(*p - '0'); + p++; + if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */ + || (UCHAR(*p) >= '8')) { + break; } - break; - case '\n': - count--; - do { - p++; count++; - } while ((count < numBytes) && ((*p == ' ') || (*p == '\t'))); - result = ' '; - break; - case 0: - result = '\\'; - count = 1; - break; - default: - /* - * Check for an octal number \oo?o? - */ - if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */ - result = (unsigned char)(*p - '0'); - p++; - if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */ - || (UCHAR(*p) >= '8')) { - break; - } - count = 3; - result = (unsigned char)((result << 3) + (*p - '0')); - p++; - if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */ - || (UCHAR(*p) >= '8')) { - break; - } - count = 4; - result = (unsigned char)((result << 3) + (*p - '0')); - break; - } - /* - * We have to convert here in case the user has put a - * backslash in front of a multi-byte utf-8 character. - * While this means nothing special, we shouldn't break up - * a correct utf-8 character. [Bug #217987] test subst-3.2 - */ - if (Tcl_UtfCharComplete(p, numBytes - 1)) { - count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */ - } else { - char utfBytes[TCL_UTF_MAX]; - memcpy(utfBytes, p, (size_t) (numBytes - 1)); - utfBytes[numBytes - 1] = '\0'; - count = Tcl_UtfToUniChar(utfBytes, &result) + 1; + count = 3; + result = (unsigned char)((result << 3) + (*p - '0')); + p++; + if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */ + || (UCHAR(*p) >= '8')) { + break; } - break; + count = 4; + result = (unsigned char)((result << 3) + (*p - '0')); + break; + } + + /* + * We have to convert here in case the user has put a backslash in + * front of a multi-byte utf-8 character. While this means nothing + * special, we shouldn't break up a correct utf-8 character. [Bug + * #217987] test subst-3.2 + */ + + if (Tcl_UtfCharComplete(p, numBytes - 1)) { + count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */ + } else { + char utfBytes[TCL_UTF_MAX]; + + memcpy(utfBytes, p, (size_t) (numBytes - 1)); + utfBytes[numBytes - 1] = '\0'; + count = Tcl_UtfToUniChar(utfBytes, &result) + 1; + } + break; } - done: + done: if (readPtr != NULL) { - *readPtr = count; + *readPtr = count; } return Tcl_UniCharToUtf((int) result, dst); } @@ -756,57 +768,66 @@ TclParseBackslash(src, numBytes, readPtr, dst) * * ParseComment -- * - * Scans up to numBytes bytes starting at src, consuming a - * Tcl comment as defined by Tcl's parsing rules. + * Scans up to numBytes bytes starting at src, consuming a Tcl comment as + * defined by Tcl's parsing rules. * * Results: - * Records in parsePtr information about the parse. Returns the - * number of bytes consumed. + * Records in parsePtr information about the parse. Returns the number of + * bytes consumed. * * Side effects: * None. * *---------------------------------------------------------------------- */ + static int ParseComment(src, numBytes, parsePtr) CONST char *src; /* First character to parse. */ register int numBytes; /* Max number of bytes to scan. */ Tcl_Parse *parsePtr; /* Information about parse in progress. - * Updated if parsing indicates - * an incomplete command. */ + * Updated if parsing indicates an incomplete + * command. */ { register CONST char *p = src; while (numBytes) { char type; int scanned; + do { scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type); - p += scanned; numBytes -= scanned; + p += scanned; + numBytes -= scanned; } while (numBytes && (*p == '\n') && (p++,numBytes--)); + if ((numBytes == 0) || (*p != '#')) { break; } if (parsePtr->commentStart == NULL) { parsePtr->commentStart = p; } + while (numBytes) { if (*p == '\\') { scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type); if (scanned) { - p += scanned; numBytes -= scanned; + p += scanned; + numBytes -= scanned; } else { /* - * General backslash substitution in comments isn't - * part of the formal spec, but test parse-15.47 - * and history indicate that it has been the de facto - * rule. Don't change it now. + * General backslash substitution in comments isn't part + * of the formal spec, but test parse-15.47 and history + * indicate that it has been the de facto rule. Don't + * change it now. */ + TclParseBackslash(p, numBytes, &scanned, NULL); - p += scanned; numBytes -= scanned; + p += scanned; + numBytes -= scanned; } } else { - p++; numBytes--; + p++; + numBytes--; if (p[-1] == '\n') { break; } @@ -816,27 +837,25 @@ ParseComment(src, numBytes, parsePtr) } return (p - src); } - + /* *---------------------------------------------------------------------- * * ParseTokens -- * - * This procedure forms the heart of the Tcl parser. It parses one - * or more tokens from a string, up to a termination point - * specified by the caller. This procedure is used to parse - * unquoted command words (those not in quotes or braces), words in - * quotes, and array indices for variables. No more than numBytes - * bytes will be scanned. + * This function forms the heart of the Tcl parser. It parses one or more + * tokens from a string, up to a termination point specified by the + * caller. This function is used to parse unquoted command words (those + * not in quotes or braces), words in quotes, and array indices for + * variables. No more than numBytes bytes will be scanned. * * Results: - * Tokens are added to parsePtr and parsePtr->term is filled in - * with the address of the character that terminated the parse (the - * first one whose CHAR_TYPE matched mask or the character at - * parsePtr->end). The return value is TCL_OK if the parse - * completed successfully and TCL_ERROR otherwise. If a parse - * error occurs and parsePtr->interp isn't NULL, then an error - * message is left in the interpreter's result. + * Tokens are added to parsePtr and parsePtr->term is filled in with the + * address of the character that terminated the parse (the first one + * whose CHAR_TYPE matched mask or the character at parsePtr->end). The + * return value is TCL_OK if the parse completed successfully and + * TCL_ERROR otherwise. If a parse error occurs and parsePtr->interp is + * not NULL, then an error message is left in the interpreter's result. * * Side effects: * None. @@ -848,19 +867,19 @@ static int ParseTokens(src, numBytes, mask, flags, parsePtr) register CONST char *src; /* First character to parse. */ register int numBytes; /* Max number of bytes to scan. */ - int flags; /* OR-ed bits indicating what substitutions - to perform: TCL_SUBST_COMMANDS, - TCL_SUBST_VARIABLES, and + int flags; /* OR-ed bits indicating what substitutions to + perform: TCL_SUBST_COMMANDS, + TCL_SUBST_VARIABLES, and TCL_SUBST_BACKSLASHES */ - int mask; /* Specifies when to stop parsing. The - * parse stops at the first unquoted - * character whose CHAR_TYPE contains - * any of the bits in mask. */ + int mask; /* Specifies when to stop parsing. The parse + * stops at the first unquoted character whose + * CHAR_TYPE contains any of the bits in + * mask. */ Tcl_Parse *parsePtr; /* Information about parse in progress. * Updated with additional tokens and * termination information. */ { - char type; + char type; int originalTokens, varToken; int noSubstCmds = !(flags & TCL_SUBST_COMMANDS); int noSubstVars = !(flags & TCL_SUBST_VARIABLES); @@ -869,10 +888,10 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) Tcl_Parse nested; /* - * Each iteration through the following loop adds one token of - * type TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or - * TCL_TOKEN_VARIABLE to parsePtr. For TCL_TOKEN_VARIABLE tokens, - * additional tokens are added for the parsed variable name. + * Each iteration through the following loop adds one token of type + * TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or TCL_TOKEN_VARIABLE + * to parsePtr. For TCL_TOKEN_VARIABLE tokens, additional tokens are added + * for the parsed variable name. */ originalTokens = parsePtr->numTokens; @@ -886,11 +905,11 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) if ((type & TYPE_SUBS) == 0) { /* - * This is a simple range of characters. Scan to find the end - * of the range. + * This is a simple range of characters. Scan to find the end of + * the range. */ - while ((++src, --numBytes) + while ((++src, --numBytes) && !(CHAR_TYPE(*src) & (mask | TYPE_SUBS))) { /* empty loop */ } @@ -902,12 +921,14 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; - src++; numBytes--; + src++; + numBytes--; continue; } + /* - * This is a variable reference. Call Tcl_ParseVarName to do - * all the dirty work of parsing the name. + * This is a variable reference. Call Tcl_ParseVarName to do all + * the dirty work of parsing the name. */ varToken = parsePtr->numTokens; @@ -922,16 +943,19 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; - src++; numBytes--; + src++; + numBytes--; continue; } + /* - * Command substitution. Call Tcl_ParseCommand recursively - * (and repeatedly) to parse the nested command(s), then - * throw away the parse information. + * Command substitution. Call Tcl_ParseCommand recursively (and + * repeatedly) to parse the nested command(s), then throw away the + * parse information. */ - src++; numBytes--; + src++; + numBytes--; while (1) { if (Tcl_ParseCommand(parsePtr->interp, src, numBytes, 1, &nested) != TCL_OK) { @@ -954,8 +978,8 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) /* * Check for the closing ']' that ends the command - * substitution. It must have been the last character of - * the parsed command. + * substitution. It must have been the last character of the + * parsed command. */ if ((nested.term < parsePtr->end) && (*nested.term == ']') @@ -965,7 +989,7 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) if (numBytes == 0) { if (parsePtr->interp != NULL) { Tcl_SetResult(parsePtr->interp, - "missing close-bracket", TCL_STATIC); + "missing close-bracket", TCL_STATIC); } parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; parsePtr->term = tokenPtr->start; @@ -981,19 +1005,26 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; - src++; numBytes--; + src++; + numBytes--; continue; } + /* * Backslash substitution. */ + TclParseBackslash(src, numBytes, &tokenPtr->size, NULL); if (tokenPtr->size == 1) { - /* Just a backslash, due to end of string */ + /* + * Just a backslash, due to end of string. + */ + tokenPtr->type = TCL_TOKEN_TEXT; parsePtr->numTokens++; - src++; numBytes--; + src++; + numBytes--; continue; } @@ -1003,9 +1034,9 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) } /* - * Note: backslash-newline is special in that it is - * treated the same as a space character would be. This - * means that it could terminate the token. + * Note: backslash-newline is special in that it is treated + * the same as a space character would be. This means that it + * could terminate the token. */ if (mask & TYPE_SPACE) { @@ -1024,17 +1055,18 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; - src++; numBytes--; + src++; + numBytes--; } else { Tcl_Panic("ParseTokens encountered unknown character"); } } if (parsePtr->numTokens == originalTokens) { /* - * There was nothing in this range of text. Add an empty token - * for the empty range, so that there is always at least one - * token added. + * There was nothing in this range of text. Add an empty token for + * the empty range, so that there is always at least one token added. */ + if (parsePtr->numTokens == parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } @@ -1042,7 +1074,7 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) tokenPtr->start = src; tokenPtr->numComponents = 0; - finishToken: + finishToken: tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 0; parsePtr->numTokens++; @@ -1050,59 +1082,59 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) parsePtr->term = src; return TCL_OK; } - + /* *---------------------------------------------------------------------- * * Tcl_FreeParse -- * - * This procedure is invoked to free any dynamic storage that may - * have been allocated by a previous call to Tcl_ParseCommand. + * This function is invoked to free any dynamic storage that may have + * been allocated by a previous call to Tcl_ParseCommand. * * Results: * None. * * Side effects: - * If there is any dynamically allocated memory in *parsePtr, - * it is freed. + * If there is any dynamically allocated memory in *parsePtr, it is + * freed. * *---------------------------------------------------------------------- */ void Tcl_FreeParse(parsePtr) - Tcl_Parse *parsePtr; /* Structure that was filled in by a - * previous call to Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Structure that was filled in by a previous + * call to Tcl_ParseCommand. */ { if (parsePtr->tokenPtr != parsePtr->staticTokens) { ckfree((char *) parsePtr->tokenPtr); parsePtr->tokenPtr = parsePtr->staticTokens; } } - + /* *---------------------------------------------------------------------- * * TclExpandTokenArray -- * - * This procedure is invoked when the current space for tokens in - * a Tcl_Parse structure fills up; it allocates memory to grow the - * token array + * This function is invoked when the current space for tokens in a + * Tcl_Parse structure fills up; it allocates memory to grow the token + * array * * Results: * None. * * Side effects: - * Memory is allocated for a new larger token array; the memory - * for the old array is freed, if it had been dynamically allocated. + * Memory is allocated for a new larger token array; the memory for the + * old array is freed, if it had been dynamically allocated. * *---------------------------------------------------------------------- */ void TclExpandTokenArray(parsePtr) - Tcl_Parse *parsePtr; /* Parse structure whose token space - * has overflowed. */ + Tcl_Parse *parsePtr; /* Parse structure whose token space has + * overflowed. */ { int newCount; Tcl_Token *newPtr; @@ -1117,52 +1149,49 @@ TclExpandTokenArray(parsePtr) parsePtr->tokenPtr = newPtr; parsePtr->tokensAvailable = newCount; } - + /* *---------------------------------------------------------------------- * * Tcl_ParseVarName -- * - * Given a string starting with a $ sign, parse off a variable - * name and return information about the parse. No more than - * numBytes bytes will be scanned. + * Given a string starting with a $ sign, parse off a variable name and + * return information about the parse. No more than numBytes bytes will + * be scanned. * * Results: - * The return value is TCL_OK if the command was parsed - * successfully and TCL_ERROR otherwise. If an error occurs and - * interp isn't NULL then an error message is left in its result. - * On a successful return, tokenPtr and numTokens fields of - * parsePtr are filled in with information about the variable name - * that was parsed. The "size" field of the first new token gives - * the total number of bytes in the variable name. Other fields in - * parsePtr are undefined. + * The return value is TCL_OK if the command was parsed successfully and + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an + * error message is left in its result. On a successful return, tokenPtr + * and numTokens fields of parsePtr are filled in with information about + * the variable name that was parsed. The "size" field of the first new + * token gives the total number of bytes in the variable name. Other + * fields in parsePtr are undefined. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the command, then additional space is - * malloc-ed. If the procedure returns TCL_OK then the caller must - * eventually invoke Tcl_FreeParse to release any additional space - * that was allocated. + * If there is insufficient space in parsePtr to hold all the information + * about the command, then additional space is malloc-ed. If the function + * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to + * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) - Tcl_Interp *interp; /* Interpreter to use for error reporting; - * if NULL, then no error message is - * provided. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting; if + * NULL, then no error message is provided. */ CONST char *start; /* Start of variable substitution string. * First character must be "$". */ - register int numBytes; /* Total number of bytes in string. If < 0, + register int numBytes; /* Total number of bytes in string. If < 0, * the string consists of all bytes up to the * first null character. */ - Tcl_Parse *parsePtr; /* Structure to fill in with information - * about the variable name. */ + Tcl_Parse *parsePtr; /* Structure to fill in with information about + * the variable name. */ int append; /* Non-zero means append tokens to existing * information in parsePtr; zero means ignore - * existing tokens in parsePtr and reinitialize - * it. */ + * existing tokens in parsePtr and + * reinitialize it. */ { Tcl_Token *tokenPtr; register CONST char *src; @@ -1183,9 +1212,8 @@ Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) } /* - * Generate one token for the variable, an additional token for the - * name, plus any number of additional tokens for the index, if - * there is one. + * Generate one token for the variable, an additional token for the name, + * plus any number of additional tokens for the index, if there is one. */ src = start; @@ -1198,7 +1226,8 @@ Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) varIndex = parsePtr->numTokens; parsePtr->numTokens++; tokenPtr++; - src++; numBytes--; + src++; + numBytes--; if (numBytes == 0) { goto justADollarSign; } @@ -1208,29 +1237,30 @@ Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) /* * The name of the variable can have three forms: - * 1. The $ sign is followed by an open curly brace. Then - * the variable name is everything up to the next close - * curly brace, and the variable is a scalar variable. - * 2. The $ sign is not followed by an open curly brace. Then - * the variable name is everything up to the next - * character that isn't a letter, digit, or underscore. - * :: sequences are also considered part of the variable - * name, in order to support namespaces. If the following - * character is an open parenthesis, then the information - * between parentheses is the array element name. - * 3. The $ sign is followed by something that isn't a letter, - * digit, or underscore: in this case, there is no variable - * name and the token is just "$". + * 1. The $ sign is followed by an open curly brace. Then the variable + * name is everything up to the next close curly brace, and the + * variable is a scalar variable. + * 2. The $ sign is not followed by an open curly brace. Then the + * variable name is everything up to the next character that isn't a + * letter, digit, or underscore. :: sequences are also considered part + * of the variable name, in order to support namespaces. If the + * following character is an open parenthesis, then the information + * between parentheses is the array element name. + * 3. The $ sign is followed by something that isn't a letter, digit, or + * underscore: in this case, there is no variable name and the token is + * just "$". */ if (*src == '{') { - src++; numBytes--; + src++; + numBytes--; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; while (numBytes && (*src != '}')) { - numBytes--; src++; + numBytes--; + src++; } if (numBytes == 0) { if (interp != NULL) { @@ -1250,24 +1280,29 @@ Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; + while (numBytes) { if (Tcl_UtfCharComplete(src, numBytes)) { - offset = Tcl_UtfToUniChar(src, &ch); + offset = Tcl_UtfToUniChar(src, &ch); } else { char utfBytes[TCL_UTF_MAX]; + memcpy(utfBytes, src, (size_t) numBytes); utfBytes[numBytes] = '\0'; - offset = Tcl_UtfToUniChar(utfBytes, &ch); + offset = Tcl_UtfToUniChar(utfBytes, &ch); } c = UCHAR(ch); if (isalnum(c) || (c == '_')) { /* INTL: ISO only, UCHAR. */ - src += offset; numBytes -= offset; + src += offset; + numBytes -= offset; continue; } if ((c == ':') && (numBytes != 1) && (src[1] == ':')) { - src += 2; numBytes -= 2; + src += 2; + numBytes -= 2; while (numBytes && (*src == ':')) { - src++; numBytes--; + src++; + numBytes--; } continue; } @@ -1277,6 +1312,7 @@ Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) /* * Support for empty array names here. */ + array = (numBytes && (*src == '(')); tokenPtr->size = src - tokenPtr->start; if ((tokenPtr->size == 0) && !array) { @@ -1285,17 +1321,16 @@ Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) parsePtr->numTokens++; if (array) { /* - * This is a reference to an array element. Call - * ParseTokens recursively to parse the element name, - * since it could contain any number of substitutions. + * This is a reference to an array element. Call ParseTokens + * recursively to parse the element name, since it could contain + * any number of substitutions. */ if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, TCL_SUBST_ALL, parsePtr)) { goto error; } - if ((parsePtr->term == (src + numBytes)) - || (*parsePtr->term != ')')) { + if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')) { if (parsePtr->interp != NULL) { Tcl_SetResult(parsePtr->interp, "missing )", TCL_STATIC); @@ -1314,38 +1349,37 @@ Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) return TCL_OK; /* - * The dollar sign isn't followed by a variable name. - * replace the TCL_TOKEN_VARIABLE token with a - * TCL_TOKEN_TEXT token for the dollar sign. + * The dollar sign isn't followed by a variable name. Replace the + * TCL_TOKEN_VARIABLE token with a TCL_TOKEN_TEXT token for the dollar + * sign. */ - justADollarSign: + justADollarSign: tokenPtr = &parsePtr->tokenPtr[varIndex]; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; tokenPtr->numComponents = 0; return TCL_OK; - error: + error: Tcl_FreeParse(parsePtr); return TCL_ERROR; } - + /* *---------------------------------------------------------------------- * * Tcl_ParseVar -- * - * Given a string starting with a $ sign, parse off a variable - * name and return its value. + * Given a string starting with a $ sign, parse off a variable name and + * return its value. * * Results: - * The return value is the contents of the variable given by - * the leading characters of string. If termPtr isn't NULL, - * *termPtr gets filled in with the address of the character - * just after the last one in the variable specifier. If the - * variable doesn't exist, then the return value is NULL and - * an error message will be left in interp's result. + * The return value is the contents of the variable given by the leading + * characters of string. If termPtr isn't NULL, *termPtr gets filled in + * with the address of the character just after the last one in the + * variable specifier. If the variable doesn't exist, then the return + * value is NULL and an error message will be left in interp's result. * * Side effects: * None. @@ -1361,7 +1395,6 @@ Tcl_ParseVar(interp, start, termPtr) CONST char **termPtr; /* If non-NULL, points to word to fill * in with character just after last * one in the variable specifier. */ - { Tcl_Parse parse; register Tcl_Obj *objPtr; @@ -1389,14 +1422,14 @@ Tcl_ParseVar(interp, start, termPtr) objPtr = Tcl_GetObjResult(interp); /* - * At this point we should have an object containing the value of - * a variable. Just return the string from that object. + * At this point we should have an object containing the value of a + * variable. Just return the string from that object. * * This should have returned the object for the user to manage, but - * instead we have some weak reference to the string value in the - * object, which is why we make sure the object exists after resetting - * the result. This isn't ideal, but it's the best we can do with the - * current documented interface. -- hobbs + * instead we have some weak reference to the string value in the object, + * which is why we make sure the object exists after resetting the result. + * This isn't ideal, but it's the best we can do with the current + * documented interface. -- hobbs */ if (!Tcl_IsShared(objPtr)) { @@ -1405,57 +1438,55 @@ Tcl_ParseVar(interp, start, termPtr) Tcl_ResetResult(interp); return TclGetString(objPtr); } - + /* *---------------------------------------------------------------------- * * Tcl_ParseBraces -- * * Given a string in braces such as a Tcl command argument or a string - * value in a Tcl expression, this procedure parses the string and - * returns information about the parse. No more than numBytes bytes - * will be scanned. + * value in a Tcl expression, this function parses the string and returns + * information about the parse. No more than numBytes bytes will be + * scanned. * * Results: * The return value is TCL_OK if the string was parsed successfully and - * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then - * an error message is left in its result. On a successful return, - * tokenPtr and numTokens fields of parsePtr are filled in with - * information about the string that was parsed. Other fields in - * parsePtr are undefined. termPtr is set to point to the character - * just after the last one in the braced string. + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an + * error message is left in its result. On a successful return, tokenPtr + * and numTokens fields of parsePtr are filled in with information about + * the string that was parsed. Other fields in parsePtr are undefined. + * termPtr is set to point to the character just after the last one in + * the braced string. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the command, then additional space is - * malloc-ed. If the procedure returns TCL_OK then the caller must - * eventually invoke Tcl_FreeParse to release any additional space - * that was allocated. + * If there is insufficient space in parsePtr to hold all the information + * about the command, then additional space is malloc-ed. If the function + * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to + * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int Tcl_ParseBraces(interp, start, numBytes, parsePtr, append, termPtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting; - * if NULL, then no error message is - * provided. */ - CONST char *start; /* Start of string enclosed in braces. - * The first character must be {'. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting; if + * NULL, then no error message is provided. */ + CONST char *start; /* Start of string enclosed in braces. The + * first character must be {'. */ register int numBytes; /* Total number of bytes in string. If < 0, - * the string consists of all bytes up to - * the first null character. */ + * the string consists of all bytes up to the + * first null character. */ register Tcl_Parse *parsePtr; - /* Structure to fill in with information - * about the string. */ + /* Structure to fill in with information about + * the string. */ int append; /* Non-zero means append tokens to existing - * information in parsePtr; zero means - * ignore existing tokens in parsePtr and + * information in parsePtr; zero means ignore + * existing tokens in parsePtr and * reinitialize it. */ CONST char **termPtr; /* If non-NULL, points to word in which to - * store a pointer to the character just - * after the terminating '}' if the parse - * was successful. */ + * store a pointer to the character just after + * the terminating '}' if the parse was + * successful. */ { Tcl_Token *tokenPtr; @@ -1491,175 +1522,178 @@ Tcl_ParseBraces(interp, start, numBytes, parsePtr, append, termPtr) } } if (numBytes == 0) { - register int openBrace = 0; + goto missingBraceError; + } - parsePtr->errorType = TCL_PARSE_MISSING_BRACE; - parsePtr->term = start; - parsePtr->incomplete = 1; - if (interp == NULL) { + switch (*src) { + case '{': + level++; + break; + case '}': + if (--level == 0) { /* - * Skip straight to the exit code since we have no - * interpreter to put error message in. + * Decide if we need to finish emitting a partially-finished + * token. There are 3 cases: + * {abc \newline xyz} or {xyz} + * - finish emitting "xyz" token + * {abc \newline} + * - don't emit token after \newline + * {} - finish emitting zero-sized token + * + * The last case ensures that there is a token (even if empty) + * that describes the braced string. */ - goto error; - } - - Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); - - /* - * Guess if the problem is due to comments by searching - * the source string for a possible open brace within the - * context of a comment. Since we aren't performing a - * full Tcl parse, just look for an open brace preceded - * by a '<whitespace>#' on the same line. - */ - for (; src > start; src--) { - switch (*src) { - case '{': - openBrace = 1; - break; - case '\n': - openBrace = 0; - break; - case '#' : - if (openBrace && (isspace(UCHAR(src[-1])))) { - Tcl_AppendResult(interp, - ": possible unbalanced brace in comment", - (char *) NULL); - goto error; - } - break; + if ((src != tokenPtr->start) + || (parsePtr->numTokens == startIndex)) { + tokenPtr->size = (src - tokenPtr->start); + parsePtr->numTokens++; + } + if (termPtr != NULL) { + *termPtr = src+1; } + return TCL_OK; } + break; + case '\\': + TclParseBackslash(src, numBytes, &length, NULL); + if ((length > 1) && (src[1] == '\n')) { + /* + * A backslash-newline sequence must be collapsed, even inside + * braces, so we have to split the word into multiple tokens + * so that the backslash-newline can be represented + * explicitly. + */ - error: - Tcl_FreeParse(parsePtr); - return TCL_ERROR; + if (numBytes == 2) { + parsePtr->incomplete = 1; + } + tokenPtr->size = (src - tokenPtr->start); + if (tokenPtr->size != 0) { + parsePtr->numTokens++; + } + if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr->type = TCL_TOKEN_BS; + tokenPtr->start = src; + tokenPtr->size = length; + tokenPtr->numComponents = 0; + parsePtr->numTokens++; + + src += length - 1; + numBytes -= length - 1; + tokenPtr++; + tokenPtr->type = TCL_TOKEN_TEXT; + tokenPtr->start = src + 1; + tokenPtr->numComponents = 0; + } else { + src += length - 1; + numBytes -= length - 1; + } + break; } - switch (*src) { + } + + missingBraceError: + parsePtr->errorType = TCL_PARSE_MISSING_BRACE; + parsePtr->term = start; + parsePtr->incomplete = 1; + if (interp == NULL) { + /* + * Skip straight to the exit code since we have no interpreter to put + * error message in. + */ + + goto error; + } + + Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); + + /* + * Guess if the problem is due to comments by searching the source string + * for a possible open brace within the context of a comment. Since we + * aren't performing a full Tcl parse, just look for an open brace + * preceded by a '<whitespace>#' on the same line. + */ + + { + register int openBrace = 0; + + for (; src > start; src--) { + switch (*src) { case '{': - level++; + openBrace = 1; break; - case '}': - if (--level == 0) { - - /* - * Decide if we need to finish emitting a - * partially-finished token. There are 3 cases: - * {abc \newline xyz} or {xyz} - * - finish emitting "xyz" token - * {abc \newline} - * - don't emit token after \newline - * {} - finish emitting zero-sized token - * - * The last case ensures that there is a token - * (even if empty) that describes the braced string. - */ - - if ((src != tokenPtr->start) - || (parsePtr->numTokens == startIndex)) { - tokenPtr->size = (src - tokenPtr->start); - parsePtr->numTokens++; - } - if (termPtr != NULL) { - *termPtr = src+1; - } - return TCL_OK; - } + case '\n': + openBrace = 0; break; - case '\\': - TclParseBackslash(src, numBytes, &length, NULL); - if ((length > 1) && (src[1] == '\n')) { - /* - * A backslash-newline sequence must be collapsed, even - * inside braces, so we have to split the word into - * multiple tokens so that the backslash-newline can be - * represented explicitly. - */ - - if (numBytes == 2) { - parsePtr->incomplete = 1; - } - tokenPtr->size = (src - tokenPtr->start); - if (tokenPtr->size != 0) { - parsePtr->numTokens++; - } - if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) { - TclExpandTokenArray(parsePtr); - } - tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; - tokenPtr->type = TCL_TOKEN_BS; - tokenPtr->start = src; - tokenPtr->size = length; - tokenPtr->numComponents = 0; - parsePtr->numTokens++; - - src += length - 1; - numBytes -= length - 1; - tokenPtr++; - tokenPtr->type = TCL_TOKEN_TEXT; - tokenPtr->start = src + 1; - tokenPtr->numComponents = 0; - } else { - src += length - 1; - numBytes -= length - 1; + case '#' : + if (openBrace && (isspace(UCHAR(src[-1])))) { + Tcl_AppendResult(interp, + ": possible unbalanced brace in comment", + (char *) NULL); + goto error; } break; + } } } -} + error: + Tcl_FreeParse(parsePtr); + return TCL_ERROR; +} + /* *---------------------------------------------------------------------- * * Tcl_ParseQuotedString -- * - * Given a double-quoted string such as a quoted Tcl command argument - * or a quoted value in a Tcl expression, this procedure parses the - * string and returns information about the parse. No more than - * numBytes bytes will be scanned. + * Given a double-quoted string such as a quoted Tcl command argument or + * a quoted value in a Tcl expression, this function parses the string + * and returns information about the parse. No more than numBytes bytes + * will be scanned. * * Results: * The return value is TCL_OK if the string was parsed successfully and - * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then - * an error message is left in its result. On a successful return, - * tokenPtr and numTokens fields of parsePtr are filled in with - * information about the string that was parsed. Other fields in - * parsePtr are undefined. termPtr is set to point to the character - * just after the quoted string's terminating close-quote. + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an + * error message is left in its result. On a successful return, tokenPtr + * and numTokens fields of parsePtr are filled in with information about + * the string that was parsed. Other fields in parsePtr are undefined. + * termPtr is set to point to the character just after the quoted + * string's terminating close-quote. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the command, then additional space is - * malloc-ed. If the procedure returns TCL_OK then the caller must - * eventually invoke Tcl_FreeParse to release any additional space - * that was allocated. + * If there is insufficient space in parsePtr to hold all the information + * about the command, then additional space is malloc-ed. If the function + * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to + * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int Tcl_ParseQuotedString(interp, start, numBytes, parsePtr, append, termPtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting; - * if NULL, then no error message is - * provided. */ - CONST char *start; /* Start of the quoted string. - * The first character must be '"'. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting; if + * NULL, then no error message is provided. */ + CONST char *start; /* Start of the quoted string. The first + * character must be '"'. */ register int numBytes; /* Total number of bytes in string. If < 0, - * the string consists of all bytes up to - * the first null character. */ + * the string consists of all bytes up to the + * first null character. */ register Tcl_Parse *parsePtr; - /* Structure to fill in with information - * about the string. */ + /* Structure to fill in with information about + * the string. */ int append; /* Non-zero means append tokens to existing - * information in parsePtr; zero means - * ignore existing tokens in parsePtr and + * information in parsePtr; zero means ignore + * existing tokens in parsePtr and * reinitialize it. */ CONST char **termPtr; /* If non-NULL, points to word in which to - * store a pointer to the character just - * after the quoted string's terminating - * close-quote if the parse succeeds. */ + * store a pointer to the character just after + * the quoted string's terminating close-quote + * if the parse succeeds. */ { if ((numBytes == 0) || (start == NULL)) { return TCL_ERROR; @@ -1671,7 +1705,7 @@ Tcl_ParseQuotedString(interp, start, numBytes, parsePtr, append, termPtr) if (!append) { TclParseInit(interp, start, numBytes, parsePtr); } - + if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL, parsePtr)) { goto error; @@ -1690,35 +1724,34 @@ Tcl_ParseQuotedString(interp, start, numBytes, parsePtr, append, termPtr) } return TCL_OK; - error: + error: Tcl_FreeParse(parsePtr); return TCL_ERROR; } - + /* *---------------------------------------------------------------------- * * Tcl_SubstObj -- * - * This function performs the substitutions specified on the - * given string as described in the user documentation for the - * "subst" Tcl command. + * This function performs the substitutions specified on the given string + * as described in the user documentation for the "subst" Tcl command. * * Results: - * A Tcl_Obj* containing the substituted string, or NULL to - * indicate that an error occurred. + * A Tcl_Obj* containing the substituted string, or NULL to indicate that + * an error occurred. * * Side effects: - * See the user documentation. + * See the user documentation. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_SubstObj(interp, objPtr, flags) - Tcl_Interp *interp; /* Interpreter in which substitution occurs */ - Tcl_Obj *objPtr; /* The value to be substituted */ - int flags; /* What substitutions to do */ + Tcl_Interp *interp; /* Interpreter in which substitution occurs */ + Tcl_Obj *objPtr; /* The value to be substituted. */ + int flags; /* What substitutions to do. */ { int length, tokensLeft, code; Tcl_Parse parse; @@ -1730,28 +1763,27 @@ Tcl_SubstObj(interp, objPtr, flags) TclParseInit(interp, p, length, &parse); /* - * First parse the string rep of objPtr, as if it were enclosed - * as a "-quoted word in a normal Tcl command. Honor flags that - * selectively inhibit types of substitution. + * First parse the string rep of objPtr, as if it were enclosed as a + * "-quoted word in a normal Tcl command. Honor flags that selectively + * inhibit types of substitution. */ if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, &parse)) { - /* - * There was a parse error. Save the error message for - * possible reporting later. + * There was a parse error. Save the error message for possible + * reporting later. */ errMsg = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errMsg); /* - * We need to re-parse to get the portion of the string we can - * [subst] before the parse error. Sadly, all the Tcl_Token's - * created by the first parse attempt are gone, freed according to the - * public spec for the Tcl_Parse* routines. The only clue we have - * is parse.term, which points to either the unmatched opener, or - * to characters that follow a close brace or close quote. + * We need to re-parse to get the portion of the string we can [subst] + * before the parse error. Sadly, all the Tcl_Token's created by the + * first parse attempt are gone, freed according to the public spec + * for the Tcl_Parse* routines. The only clue we have is parse.term, + * which points to either the unmatched opener, or to characters that + * follow a close brace or close quote. * * Call ParseTokens again, working on the string up to parse.term. * Keep repeating until we get a good parse on a prefix. @@ -1765,123 +1797,134 @@ Tcl_SubstObj(interp, objPtr, flags) parse.errorType = TCL_PARSE_SUCCESS; } while (TCL_OK != ParseTokens(p, parse.end - p, 0, flags, &parse)); - /* The good parse will have to be followed by {, (, or [. */ + /* + * The good parse will have to be followed by {, (, or [. + */ + switch (*parse.term) { - case '{': + case '{': + /* + * Parse error was a missing } in a ${varname} variable + * substitution at the toplevel. We will subst everything up to + * that broken variable substitution before reporting the parse + * error. Substituting the leftover '$' will have no side-effects, + * so the current token stream is fine. + */ + break; + + case '(': + /* + * Parse error was during the parsing of the index part of an + * array variable substitution at the toplevel. + */ + + if (*(parse.term - 1) == '$') { /* - * Parse error was a missing } in a ${varname} variable - * substitution at the toplevel. We will subst everything - * up to that broken variable substitution before reporting - * the parse error. Substituting the leftover '$' will - * have no side-effects, so the current token stream is fine. + * Special case where removing the array index left us with + * just a dollar sign (array variable with name the empty + * string as its name), instead of with a scalar variable + * reference. + * + * As in the previous case, existing token stream is OK. */ - break; - case '(': + } else { /* - * Parse error was during the parsing of the index part of - * an array variable substitution at the toplevel. + * The current parse includes a successful parse of a scalar + * variable substitution where there should have been an array + * variable substitution. We remove that mistaken part of the + * parse before moving on. A scalar variable substitution is + * two tokens. */ - if (*(parse.term - 1) == '$') { - /* - * Special case where removing the array index left - * us with just a dollar sign (array variable with - * name the empty string as its name), instead of - * with a scalar variable reference. - * - * As in the previous case, existing token stream is OK. - */ - } else { - /* The current parse includes a successful parse of a - * scalar variable substitution where there should have - * been an array variable substitution. We remove that - * mistaken part of the parse before moving on. A scalar - * variable substitution is two tokens. - */ - Tcl_Token *varTokenPtr = - parse.tokenPtr + parse.numTokens - 2; - - if (varTokenPtr->type != TCL_TOKEN_VARIABLE) { - Tcl_Panic("Tcl_SubstObj: programming error"); - } - if (varTokenPtr[1].type != TCL_TOKEN_TEXT) { - Tcl_Panic("Tcl_SubstObj: programming error"); - } - parse.numTokens -= 2; + + Tcl_Token *varTokenPtr = + parse.tokenPtr + parse.numTokens - 2; + + if (varTokenPtr->type != TCL_TOKEN_VARIABLE) { + Tcl_Panic("Tcl_SubstObj: programming error"); } - break; - case '[': + if (varTokenPtr[1].type != TCL_TOKEN_TEXT) { + Tcl_Panic("Tcl_SubstObj: programming error"); + } + parse.numTokens -= 2; + } + break; + case '[': + /* + * Parse error occurred during parsing of a toplevel command + * substitution. + */ + + parse.end = p + length; + p = parse.term + 1; + length = parse.end - p; + if (length == 0) { + /* + * No commands, just an unmatched [. As in previous cases, + * existing token stream is OK. + */ + } else { /* - * Parse error occurred during parsing of a toplevel - * command substitution. + * We want to add the parsing of as many commands as we can + * within that substitution until we reach the actual parse + * error. We'll do additional parsing to determine what + * length to claim for the final TCL_TOKEN_COMMAND token. */ - parse.end = p + length; - p = parse.term + 1; - length = parse.end - p; - if (length == 0) { - /* - * No commands, just an unmatched [. - * As in previous cases, existing token stream is OK. - */ - } else { - /* - * We want to add the parsing of as many commands as we - * can within that substitution until we reach the - * actual parse error. We'll do additional parsing to - * determine what length to claim for the final - * TCL_TOKEN_COMMAND token. - */ - Tcl_Token *tokenPtr; - Tcl_Parse nested; - CONST char *lastTerm = parse.term; - - while (TCL_OK == - Tcl_ParseCommand(NULL, p, length, 0, &nested)) { - Tcl_FreeParse(&nested); - p = nested.term + (nested.term < nested.end); - length = nested.end - p; - if ((length == 0) && (nested.term == nested.end)) { - /* - * If we run out of string, blame the missing - * close bracket on the last command, and do - * not evaluate it during substitution. - */ - break; - } - lastTerm = nested.term; - } + Tcl_Token *tokenPtr; + Tcl_Parse nested; + CONST char *lastTerm = parse.term; - if (lastTerm == parse.term) { + while (TCL_OK == + Tcl_ParseCommand(NULL, p, length, 0, &nested)) { + Tcl_FreeParse(&nested); + p = nested.term + (nested.term < nested.end); + length = nested.end - p; + if ((length == 0) && (nested.term == nested.end)) { /* - * Parse error in first command. No commands - * to subst, add no more tokens. + * If we run out of string, blame the missing close + * bracket on the last command, and do not evaluate it + * during substitution. */ + break; } + lastTerm = nested.term; + } + if (lastTerm == parse.term) { /* - * Create a command substitution token for whatever - * commands got parsed. + * Parse error in first command. No commands to subst, + * add no more tokens. */ + break; + } - if (parse.numTokens == parse.tokensAvailable) { - TclExpandTokenArray(&parse); - } - tokenPtr = &parse.tokenPtr[parse.numTokens]; - tokenPtr->start = parse.term; - tokenPtr->numComponents = 0; - tokenPtr->type = TCL_TOKEN_COMMAND; - tokenPtr->size = lastTerm - tokenPtr->start + 1; - parse.numTokens++; + /* + * Create a command substitution token for whatever commands + * got parsed. + */ + + if (parse.numTokens == parse.tokensAvailable) { + TclExpandTokenArray(&parse); } - break; + tokenPtr = &parse.tokenPtr[parse.numTokens]; + tokenPtr->start = parse.term; + tokenPtr->numComponents = 0; + tokenPtr->type = TCL_TOKEN_COMMAND; + tokenPtr->size = lastTerm - tokenPtr->start + 1; + parse.numTokens++; + } + break; - default: - Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]); + default: + Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]); } } - /* Next, substitute the parsed tokens just as in normal Tcl evaluation */ + /* + * Next, substitute the parsed tokens just as in normal Tcl evaluation. + */ + endTokenPtr = parse.tokenPtr + parse.numTokens; tokensLeft = parse.numTokens; code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, @@ -1895,20 +1938,21 @@ Tcl_SubstObj(interp, objPtr, flags) } return Tcl_GetObjResult(interp); } + result = Tcl_NewObj(); while (1) { switch (code) { - case TCL_ERROR: - Tcl_FreeParse(&parse); - Tcl_DecrRefCount(result); - if (errMsg != NULL) { - Tcl_DecrRefCount(errMsg); - } - return NULL; - case TCL_BREAK: - tokensLeft = 0; /* Halt substitution */ - default: - Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp)); + case TCL_ERROR: + Tcl_FreeParse(&parse); + Tcl_DecrRefCount(result); + if (errMsg != NULL) { + Tcl_DecrRefCount(errMsg); + } + return NULL; + case TCL_BREAK: + tokensLeft = 0; /* Halt substitution */ + default: + Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp)); } if (tokensLeft == 0) { @@ -1929,23 +1973,22 @@ Tcl_SubstObj(interp, objPtr, flags) &tokensLeft); } } - + /* *---------------------------------------------------------------------- * * TclSubstTokens -- * - * Accepts an array of count Tcl_Token's, and creates a result - * value in the interp from concatenating the results of - * performing Tcl substitution on each Tcl_Token. Substitution - * is interrupted if any non-TCL_OK completion code arises. + * Accepts an array of count Tcl_Token's, and creates a result value in + * the interp from concatenating the results of performing Tcl + * substitution on each Tcl_Token. Substitution is interrupted if any + * non-TCL_OK completion code arises. * * Results: - * The return value is a standard Tcl completion code. The - * result in interp is the substituted value, or an error message - * if TCL_ERROR is returned. If tokensLeftPtr is not NULL, then - * it points to an int where the number of tokens remaining to - * be processed is written. + * The return value is a standard Tcl completion code. The result in + * interp is the substituted value, or an error message if TCL_ERROR is + * returned. If tokensLeftPtr is not NULL, then it points to an int where + * the number of tokens remaining to be processed is written. * * Side effects: * Can be anything, depending on the types of substitution done. @@ -1955,13 +1998,13 @@ Tcl_SubstObj(interp, objPtr, flags) int TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr) - Tcl_Interp *interp; /* Interpreter in which to lookup - * variables, execute nested commands, - * and report errors. */ - Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens - * to evaluate and concatenate. */ - int count; /* Number of tokens to consider at tokenPtr. - * Must be at least 1. */ + Tcl_Interp *interp; /* Interpreter in which to lookup variables, + * execute nested commands, and report + * errors. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens to + * evaluate and concatenate. */ + int count; /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ int *tokensLeftPtr; /* If not NULL, points to memory where an * integer representing the number of tokens * left to be substituted will be written */ @@ -1971,115 +2014,125 @@ TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr) /* * Each pass through this loop will substitute one token, and its - * components, if any. The only thing tricky here is that we go to - * some effort to pass Tcl_Obj's through untouched, to avoid string - * copying and Tcl_Obj creation if possible, to aid performance and - * limit shimmering. + * components, if any. The only thing tricky here is that we go to some + * effort to pass Tcl_Obj's through untouched, to avoid string copying and + * Tcl_Obj creation if possible, to aid performance and limit shimmering. * - * Further optimization opportunities might be to check for the - * equivalent of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp)) - * and omit them. + * Further optimization opportunities might be to check for the equivalent + * of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp)) and omit them. */ result = NULL; - for ( ; (count > 0) && (code == TCL_OK); count--, tokenPtr++) { + for (; count>0 && code==TCL_OK ; count--, tokenPtr++) { Tcl_Obj *appendObj = NULL; CONST char *append = NULL; int appendByteLength = 0; char utfCharBytes[TCL_UTF_MAX]; switch (tokenPtr->type) { - case TCL_TOKEN_TEXT: - append = tokenPtr->start; - appendByteLength = tokenPtr->size; - break; + case TCL_TOKEN_TEXT: + append = tokenPtr->start; + appendByteLength = tokenPtr->size; + break; - case TCL_TOKEN_BS: { - appendByteLength = Tcl_UtfBackslash(tokenPtr->start, - (int *) NULL, utfCharBytes); - append = utfCharBytes; - break; - } + case TCL_TOKEN_BS: + appendByteLength = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, + utfCharBytes); + append = utfCharBytes; + break; - case TCL_TOKEN_COMMAND: { - Interp *iPtr = (Interp *) interp; - iPtr->numLevels++; - code = TclInterpReady(interp); - if (code == TCL_OK) { - code = Tcl_EvalEx(interp, - tokenPtr->start+1, tokenPtr->size-2, 0); - } - iPtr->numLevels--; - appendObj = Tcl_GetObjResult(interp); - break; + case TCL_TOKEN_COMMAND: { + Interp *iPtr = (Interp *) interp; + + iPtr->numLevels++; + code = TclInterpReady(interp); + if (code == TCL_OK) { + code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2, + 0); } + iPtr->numLevels--; + appendObj = Tcl_GetObjResult(interp); + break; + } - case TCL_TOKEN_VARIABLE: { - Tcl_Obj *arrayIndex = NULL; - Tcl_Obj *varName = NULL; - if (tokenPtr->numComponents > 1) { - /* Subst the index part of an array variable reference */ - code = TclSubstTokens(interp, tokenPtr+2, - tokenPtr->numComponents - 1, NULL); - arrayIndex = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(arrayIndex); - } + case TCL_TOKEN_VARIABLE: { + Tcl_Obj *arrayIndex = NULL; + Tcl_Obj *varName = NULL; - if (code == TCL_OK) { - varName = Tcl_NewStringObj(tokenPtr[1].start, - tokenPtr[1].size); - appendObj = Tcl_ObjGetVar2(interp, varName, arrayIndex, - TCL_LEAVE_ERR_MSG); - Tcl_DecrRefCount(varName); - if (appendObj == NULL) { - code = TCL_ERROR; - } - } + if (tokenPtr->numComponents > 1) { + /* + * Subst the index part of an array variable reference. + */ - switch (code) { - case TCL_OK: /* Got value */ - case TCL_ERROR: /* Already have error message */ - case TCL_BREAK: /* Will not substitute anyway */ - case TCL_CONTINUE: /* Will not substitute anyway */ - break; - default: - /* All other return codes, we will subst the - * result from the code-throwing evaluation */ - appendObj = Tcl_GetObjResult(interp); - } + code = TclSubstTokens(interp, tokenPtr+2, + tokenPtr->numComponents - 1, NULL); + arrayIndex = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(arrayIndex); + } - if (arrayIndex != NULL) { - Tcl_DecrRefCount(arrayIndex); + if (code == TCL_OK) { + varName = Tcl_NewStringObj(tokenPtr[1].start, + tokenPtr[1].size); + appendObj = Tcl_ObjGetVar2(interp, varName, arrayIndex, + TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(varName); + if (appendObj == NULL) { + code = TCL_ERROR; } - count -= tokenPtr->numComponents; - tokenPtr += tokenPtr->numComponents; - break; } + switch (code) { + case TCL_OK: /* Got value */ + case TCL_ERROR: /* Already have error message */ + case TCL_BREAK: /* Will not substitute anyway */ + case TCL_CONTINUE: /* Will not substitute anyway */ + break; default: - Tcl_Panic("unexpected token type in TclSubstTokens: %d", - tokenPtr->type); + /* + * All other return codes, we will subst the result from the + * code-throwing evaluation. + */ + + appendObj = Tcl_GetObjResult(interp); + } + + if (arrayIndex != NULL) { + Tcl_DecrRefCount(arrayIndex); + } + count -= tokenPtr->numComponents; + tokenPtr += tokenPtr->numComponents; + break; + } + + default: + Tcl_Panic("unexpected token type in TclSubstTokens: %d", + tokenPtr->type); } if ((code == TCL_BREAK) || (code == TCL_CONTINUE)) { - /* Inhibit substitution */ + /* + * Inhibit substitution. + */ continue; } if (result == NULL) { - /* - * First pass through. If we have a Tcl_Obj, just use it. - * If not, create one from our string. + /* + * First pass through. If we have a Tcl_Obj, just use it. If not, + * create one from our string. */ if (appendObj != NULL) { result = appendObj; } else { - result = Tcl_NewStringObj(append, appendByteLength);; + result = Tcl_NewStringObj(append, appendByteLength); } Tcl_IncrRefCount(result); } else { - /* Subsequent passes. Append to result. */ + /* + * Subsequent passes. Append to result. + */ + if (Tcl_IsShared(result)) { Tcl_DecrRefCount(result); result = Tcl_DuplicateObj(result); @@ -2093,7 +2146,7 @@ TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr) } } - if (code != TCL_ERROR) { /* Keep error message in result! */ + if (code != TCL_ERROR) { /* Keep error message in result! */ if (result != NULL) { Tcl_SetObjResult(interp, result); } else { @@ -2114,14 +2167,14 @@ TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr) * * CommandComplete -- * - * This procedure is shared by TclCommandComplete and - * Tcl_ObjCommandComplete; it does all the real work of seeing - * whether a script is complete + * This function is shared by TclCommandComplete and + * Tcl_ObjCommandComplete; it does all the real work of seeing whether a + * script is complete * * Results: * 1 is returned if the script is complete, 0 if there are open - * delimiters such as " or (. 1 is also returned if there is a - * parse error in the script other than unmatched delimiters. + * delimiters such as " or (. 1 is also returned if there is a parse + * error in the script other than unmatched delimiters. * * Side effects: * None. @@ -2131,8 +2184,8 @@ TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr) static int CommandComplete(script, numBytes) - CONST char *script; /* Script to check. */ - int numBytes; /* Number of bytes in script. */ + CONST char *script; /* Script to check. */ + int numBytes; /* Number of bytes in script. */ { Tcl_Parse parse; CONST char *p, *end; @@ -2156,20 +2209,20 @@ CommandComplete(script, numBytes) Tcl_FreeParse(&parse); return result; } - + /* *---------------------------------------------------------------------- * * Tcl_CommandComplete -- * - * Given a partial or complete Tcl script, this procedure - * determines whether the script is complete in the sense - * of having matched braces and quotes and brackets. + * Given a partial or complete Tcl script, this function determines + * whether the script is complete in the sense of having matched braces + * and quotes and brackets. * * Results: - * 1 is returned if the script is complete, 0 otherwise. - * 1 is also returned if there is a parse error in the script - * other than unmatched delimiters. + * 1 is returned if the script is complete, 0 otherwise. 1 is also + * returned if there is a parse error in the script other than unmatched + * delimiters. * * Side effects: * None. @@ -2179,19 +2232,19 @@ CommandComplete(script, numBytes) int Tcl_CommandComplete(script) - CONST char *script; /* Script to check. */ + CONST char *script; /* Script to check. */ { return CommandComplete(script, (int) strlen(script)); } - + /* *---------------------------------------------------------------------- * * TclObjCommandComplete -- * - * Given a partial or complete Tcl command in a Tcl object, this - * procedure determines whether the command is complete in the sense of - * having matched braces and quotes and brackets. + * Given a partial or complete Tcl command in a Tcl object, this function + * determines whether the command is complete in the sense of having + * matched braces and quotes and brackets. * * Results: * 1 is returned if the command is complete, 0 otherwise. @@ -2204,8 +2257,8 @@ Tcl_CommandComplete(script) int TclObjCommandComplete(objPtr) - Tcl_Obj *objPtr; /* Points to object holding script - * to check. */ + Tcl_Obj *objPtr; /* Points to object holding script to + * check. */ { CONST char *script; int length; @@ -2213,14 +2266,14 @@ TclObjCommandComplete(objPtr) script = Tcl_GetStringFromObj(objPtr, &length); return CommandComplete(script, length); } - + /* *---------------------------------------------------------------------- * * TclIsLocalScalar -- * - * Check to see if a given string is a legal scalar variable - * name with no namespace qualifiers or substitutions. + * Check to see if a given string is a legal scalar variable name with no + * namespace qualifiers or substitutions. * * Results: * Returns 1 if the variable is a local scalar. @@ -2239,13 +2292,13 @@ TclIsLocalScalar(src, len) CONST char *p; CONST char *lastChar = src + (len - 1); - for (p = src; p <= lastChar; p++) { + for (p=src ; p<=lastChar ; p++) { if ((CHAR_TYPE(*p) != TYPE_NORMAL) && (CHAR_TYPE(*p) != TYPE_COMMAND_END)) { /* - * TCL_COMMAND_END is returned for the last character - * of the string. By this point we know it isn't - * an array or namespace reference. + * TCL_COMMAND_END is returned for the last character of the + * string. By this point we know it isn't an array or namespace + * reference. */ return 0; @@ -2260,6 +2313,14 @@ TclIsLocalScalar(src, len) } } } - + return 1; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c index b07dd30..b6f3548 100644 --- a/generic/tclParseExpr.c +++ b/generic/tclParseExpr.c @@ -1,27 +1,26 @@ -/* +/* * tclParseExpr.c -- * - * This file contains procedures that parse Tcl expressions. They - * do so in a general-purpose fashion that can be used for many - * different purposes, including compilation, direct execution, - * code analysis, etc. + * This file contains functions that parse Tcl expressions. They do so in + * a general-purpose fashion that can be used for many different + * purposes, including compilation, direct execution, code analysis, etc. * * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParseExpr.c,v 1.26 2005/05/20 15:29:33 dgp Exp $ + * RCS: @(#) $Id: tclParseExpr.c,v 1.27 2005/07/21 14:38:50 dkf Exp $ */ #include "tclInt.h" /* * The stuff below is a bit of a hack so that this file can be used in - * environments that include no UNIX, i.e. no errno: just arrange to use - * the errno from tclExecute.c here. + * environments that include no UNIX, i.e. no errno: just arrange to use the + * errno from tclExecute.c here. */ #ifdef TCL_GENERIC_ONLY @@ -34,8 +33,7 @@ extern int errno; /* Use errno from tclExecute.c. */ #endif /* - * Boolean variable that controls whether expression parse tracing - * is enabled. + * Boolean variable that controls whether expression parse tracing is enabled. */ #ifdef TCL_COMPILE_DEBUG @@ -43,33 +41,32 @@ static int traceParseExpr = 0; #endif /* TCL_COMPILE_DEBUG */ /* - * The ParseInfo structure holds state while parsing an expression. - * A pointer to an ParseInfo record is passed among the routines in - * this module. + * The ParseInfo structure holds state while parsing an expression. A pointer + * to an ParseInfo record is passed among the routines in this module. */ typedef struct ParseInfo { Tcl_Parse *parsePtr; /* Points to structure to fill in with * information about the expression. */ - int lexeme; /* Type of last lexeme scanned in expr. - * See below for definitions. Corresponds to - * size characters beginning at start. */ + int lexeme; /* Type of last lexeme scanned in expr. See + * below for definitions. Corresponds to size + * characters beginning at start. */ CONST char *start; /* First character in lexeme. */ int size; /* Number of bytes in lexeme. */ CONST char *next; /* Position of the next character to be * scanned in the expression string. */ - CONST char *prevEnd; /* Points to the character just after the - * last one in the previous lexeme. Used to - * compute size of subexpression tokens. */ + CONST char *prevEnd; /* Points to the character just after the last + * one in the previous lexeme. Used to compute + * size of subexpression tokens. */ CONST char *originalExpr; /* Points to the start of the expression * originally passed to Tcl_ParseExpr. */ CONST char *lastChar; /* Points just after last byte of expr. */ } ParseInfo; /* - * Definitions of the different lexemes that appear in expressions. The - * order of these must match the corresponding entries in the - * operatorStrings array below. + * Definitions of the different lexemes that appear in expressions. The order + * of these must match the corresponding entries in the operatorStrings array + * below. * * Basic lexemes: */ @@ -141,8 +138,8 @@ typedef struct ParseInfo { #define NOT_IN_LIST 38 /* - * Mapping from lexemes to strings; used for debugging messages. These - * entries must match the order and number of the lexeme definitions above. + * Mapping from lexemes to strings; used for debugging messages. These entries + * must match the order and number of the lexeme definitions above. */ static char *lexemeStrings[] = { @@ -155,12 +152,12 @@ static char *lexemeStrings[] = { }; /* - * Declarations for local procedures to this file: + * Declarations for local functions to this file: */ static int GetLexeme _ANSI_ARGS_((ParseInfo *infoPtr)); static void LogSyntaxError _ANSI_ARGS_((ParseInfo *infoPtr, - CONST char *extraInfo)); + CONST char *extraInfo)); static int ParseAddExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseBitAndExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseBitOrExpr _ANSI_ARGS_((ParseInfo *infoPtr)); @@ -170,7 +167,7 @@ static int ParseEqualityExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseLandExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseLorExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseMaxDoubleLength _ANSI_ARGS_((CONST char *string, - CONST char *end)); + CONST char *end)); static int ParseMultiplyExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParsePrimaryExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseRelationalExpr _ANSI_ARGS_((ParseInfo *infoPtr)); @@ -178,12 +175,12 @@ static int ParseShiftExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseExponentialExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseUnaryExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static void PrependSubExprTokens _ANSI_ARGS_((CONST char *op, - int opBytes, CONST char *src, int srcBytes, - int firstIndex, ParseInfo *infoPtr)); + int opBytes, CONST char *src, int srcBytes, + int firstIndex, ParseInfo *infoPtr)); /* - * Macro used to debug the execution of the recursive descent parser used - * to parse expressions. + * Macro used to debug the execution of the recursive descent parser used to + * parse expressions. */ #ifdef TCL_COMPILE_DEBUG @@ -202,25 +199,26 @@ static void PrependSubExprTokens _ANSI_ARGS_((CONST char *op, * * Tcl_ParseExpr -- * - * Given a string, this procedure parses the first Tcl expression - * in the string and returns information about the structure of - * the expression. This procedure is the top-level interface to the - * the expression parsing module. No more than numBytes bytes will - * be scanned. + * Given a string, this function parses the first Tcl expression in the + * string and returns information about the structure of the expression. + * This function is the top-level interface to the the expression parsing + * module. No more than numBytes bytes will be scanned. + * + * Note that this parser is a LL(1) parser; the operator precedence rules + * are completely hard coded in the recursive structure of the parser + * itself. * * Results: - * The return value is TCL_OK if the command was parsed successfully - * and TCL_ERROR otherwise. If an error occurs and interp isn't NULL - * then an error message is left in its result. On a successful return, - * parsePtr is filled in with information about the expression that - * was parsed. + * The return value is TCL_OK if the command was parsed successfully and + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an + * error message is left in its result. On a successful return, parsePtr + * is filled in with information about the expression that was parsed. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the expression, then additional space is - * malloc-ed. If the procedure returns TCL_OK then the caller must - * eventually invoke Tcl_FreeParse to release any additional space - * that was allocated. + * If there is insufficient space in parsePtr to hold all the information + * about the expression, then additional space is malloc-ed. If the + * function returns TCL_OK then the caller must eventually invoke + * Tcl_FreeParse to release any additional space that was allocated. * *---------------------------------------------------------------------- */ @@ -234,8 +232,7 @@ Tcl_ParseExpr(interp, start, numBytes, parsePtr) * first null character. */ Tcl_Parse *parsePtr; /* Structure to fill with information about * the parsed expression; any previous - * information in the structure is - * ignored. */ + * information in the structure is ignored. */ { ParseInfo info; int code; @@ -246,15 +243,15 @@ Tcl_ParseExpr(interp, start, numBytes, parsePtr) #ifdef TCL_COMPILE_DEBUG if (traceParseExpr) { fprintf(stderr, "Tcl_ParseExpr: string=\"%.*s\"\n", - numBytes, start); + numBytes, start); } #endif /* TCL_COMPILE_DEBUG */ - + TclParseInit(interp, start, numBytes, parsePtr); /* - * Initialize the ParseInfo structure that holds state while parsing - * the expression. + * Initialize the ParseInfo structure that holds state while parsing the + * expression. */ info.parsePtr = parsePtr; @@ -283,8 +280,8 @@ Tcl_ParseExpr(interp, start, numBytes, parsePtr) goto error; } return TCL_OK; - - error: + + error: if (parsePtr->tokenPtr != parsePtr->staticTokens) { ckfree((char *) parsePtr->tokenPtr); } @@ -296,53 +293,52 @@ Tcl_ParseExpr(interp, start, numBytes, parsePtr) * * ParseCondExpr -- * - * This procedure parses a Tcl conditional expression: + * This function parses a Tcl conditional expression: * condExpr ::= lorExpr ['?' condExpr ':' condExpr] * * Note that this is the topmost recursive-descent parsing routine used - * by Tcl_ParseExpr to parse expressions. This avoids an extra procedure - * call since such a procedure would only return the result of calling - * ParseCondExpr. Other recursive-descent procedures that need to parse + * by Tcl_ParseExpr to parse expressions. This avoids an extra function + * call since such a function would only return the result of calling + * ParseCondExpr. Other recursive-descent functions that need to parse * complete expressions also call ParseCondExpr. * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseCondExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; Tcl_Token *tokenPtr, *firstTokenPtr, *condTokenPtr; int firstIndex, numToMove, code; CONST char *srcStart; - + HERE("condExpr", 1); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseLorExpr(infoPtr); if (code != TCL_OK) { return code; } - + if (infoPtr->lexeme == QUESTY) { /* * Emit two tokens: one TCL_TOKEN_SUB_EXPR token for the entire - * conditional expression, and a TCL_TOKEN_OPERATOR token for - * the "?" operator. Note that these two tokens must be inserted - * before the LOR operand tokens generated above. + * conditional expression, and a TCL_TOKEN_OPERATOR token for the "?" + * operator. Note that these two tokens must be inserted before the + * LOR operand tokens generated above. */ if ((parsePtr->numTokens + 1) >= parsePtr->tokensAvailable) { @@ -352,24 +348,24 @@ ParseCondExpr(infoPtr) tokenPtr = (firstTokenPtr + 2); numToMove = (parsePtr->numTokens - firstIndex); memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr, - (size_t) (numToMove * sizeof(Tcl_Token))); + (size_t) (numToMove * sizeof(Tcl_Token))); parsePtr->numTokens += 2; - + tokenPtr = firstTokenPtr; tokenPtr->type = TCL_TOKEN_SUB_EXPR; tokenPtr->start = srcStart; - + tokenPtr++; tokenPtr->type = TCL_TOKEN_OPERATOR; tokenPtr->start = infoPtr->start; tokenPtr->size = 1; tokenPtr->numComponents = 0; - + /* * Skip over the '?'. */ - - code = GetLexeme(infoPtr); + + code = GetLexeme(infoPtr); if (code != TCL_OK) { return code; } @@ -416,35 +412,34 @@ ParseCondExpr(infoPtr) * * ParseLorExpr -- * - * This procedure parses a Tcl logical or expression: + * This function parses a Tcl logical or expression: * lorExpr ::= landExpr {'||' landExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseLorExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, code; CONST char *srcStart, *operator; - + HERE("lorExpr", 2); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseLandExpr(infoPtr); if (code != TCL_OK) { return code; @@ -466,7 +461,7 @@ ParseLorExpr(infoPtr) */ PrependSubExprTokens(operator, 2, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } return TCL_OK; } @@ -476,26 +471,25 @@ ParseLorExpr(infoPtr) * * ParseLandExpr -- * - * This procedure parses a Tcl logical and expression: + * This function parses a Tcl logical and expression: * landExpr ::= bitOrExpr {'&&' bitOrExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseLandExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, code; @@ -504,7 +498,7 @@ ParseLandExpr(infoPtr) HERE("landExpr", 3); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseBitOrExpr(infoPtr); if (code != TCL_OK) { return code; @@ -526,7 +520,7 @@ ParseLandExpr(infoPtr) */ PrependSubExprTokens(operator, 2, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } return TCL_OK; } @@ -536,26 +530,25 @@ ParseLandExpr(infoPtr) * * ParseBitOrExpr -- * - * This procedure parses a Tcl bitwise or expression: + * This function parses a Tcl bitwise or expression: * bitOrExpr ::= bitXorExpr {'|' bitXorExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseBitOrExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, code; @@ -564,12 +557,12 @@ ParseBitOrExpr(infoPtr) HERE("bitOrExpr", 4); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseBitXorExpr(infoPtr); if (code != TCL_OK) { return code; } - + while (infoPtr->lexeme == BIT_OR) { operator = infoPtr->start; code = GetLexeme(infoPtr); /* skip over the '|' */ @@ -581,13 +574,13 @@ ParseBitOrExpr(infoPtr) if (code != TCL_OK) { return code; } - + /* * Generate tokens for the BITOR subexpression and the '|' operator. */ PrependSubExprTokens(operator, 1, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } return TCL_OK; } @@ -597,26 +590,25 @@ ParseBitOrExpr(infoPtr) * * ParseBitXorExpr -- * - * This procedure parses a Tcl bitwise exclusive or expression: + * This function parses a Tcl bitwise exclusive or expression: * bitXorExpr ::= bitAndExpr {'^' bitAndExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseBitXorExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, code; @@ -625,12 +617,12 @@ ParseBitXorExpr(infoPtr) HERE("bitXorExpr", 5); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseBitAndExpr(infoPtr); if (code != TCL_OK) { return code; } - + while (infoPtr->lexeme == BIT_XOR) { operator = infoPtr->start; code = GetLexeme(infoPtr); /* skip over the '^' */ @@ -642,13 +634,13 @@ ParseBitXorExpr(infoPtr) if (code != TCL_OK) { return code; } - + /* * Generate tokens for the XOR subexpression and the '^' operator. */ PrependSubExprTokens(operator, 1, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } return TCL_OK; } @@ -658,26 +650,25 @@ ParseBitXorExpr(infoPtr) * * ParseBitAndExpr -- * - * This procedure parses a Tcl bitwise and expression: + * This function parses a Tcl bitwise and expression: * bitAndExpr ::= equalityExpr {'&' equalityExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseBitAndExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, code; @@ -686,12 +677,12 @@ ParseBitAndExpr(infoPtr) HERE("bitAndExpr", 6); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseEqualityExpr(infoPtr); if (code != TCL_OK) { return code; } - + while (infoPtr->lexeme == BIT_AND) { operator = infoPtr->start; code = GetLexeme(infoPtr); /* skip over the '&' */ @@ -702,13 +693,13 @@ ParseBitAndExpr(infoPtr) if (code != TCL_OK) { return code; } - + /* * Generate tokens for the BITAND subexpression and '&' operator. */ PrependSubExprTokens(operator, 1, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } return TCL_OK; } @@ -718,27 +709,26 @@ ParseBitAndExpr(infoPtr) * * ParseEqualityExpr -- * - * This procedure parses a Tcl equality (inequality) expression: + * This function parses a Tcl equality (inequality) expression: * equalityExpr ::= relationalExpr * {('==' | '!=' | 'ne' | 'eq') relationalExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseEqualityExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; @@ -747,7 +737,7 @@ ParseEqualityExpr(infoPtr) HERE("equalityExpr", 7); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseRelationalExpr(infoPtr); if (code != TCL_OK) { return code; @@ -772,7 +762,7 @@ ParseEqualityExpr(infoPtr) */ PrependSubExprTokens(operator, 2, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; @@ -783,26 +773,25 @@ ParseEqualityExpr(infoPtr) * * ParseRelationalExpr -- * - * This procedure parses a Tcl relational expression: + * This function parses a Tcl relational expression: * relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseRelationalExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, operatorSize, code; @@ -811,7 +800,7 @@ ParseRelationalExpr(infoPtr) HERE("relationalExpr", 8); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseShiftExpr(infoPtr); if (code != TCL_OK) { return code; @@ -819,7 +808,7 @@ ParseRelationalExpr(infoPtr) lexeme = infoPtr->lexeme; while ((lexeme == LESS) || (lexeme == GREATER) || (lexeme == LEQ) - || (lexeme == GEQ)) { + || (lexeme == GEQ)) { operator = infoPtr->start; if ((lexeme == LEQ) || (lexeme == GEQ)) { operatorSize = 2; @@ -840,7 +829,7 @@ ParseRelationalExpr(infoPtr) */ PrependSubExprTokens(operator, operatorSize, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; @@ -851,26 +840,25 @@ ParseRelationalExpr(infoPtr) * * ParseShiftExpr -- * - * This procedure parses a Tcl shift expression: + * This function parses a Tcl shift expression: * shiftExpr ::= addExpr {('<<' | '>>') addExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseShiftExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; @@ -879,7 +867,7 @@ ParseShiftExpr(infoPtr) HERE("shiftExpr", 9); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseAddExpr(infoPtr); if (code != TCL_OK) { return code; @@ -888,7 +876,7 @@ ParseShiftExpr(infoPtr) lexeme = infoPtr->lexeme; while ((lexeme == LEFT_SHIFT) || (lexeme == RIGHT_SHIFT)) { operator = infoPtr->start; - code = GetLexeme(infoPtr); /* skip over << or >> */ + code = GetLexeme(infoPtr); /* skip over << or >> */ if (code != TCL_OK) { return code; } @@ -902,7 +890,7 @@ ParseShiftExpr(infoPtr) */ PrependSubExprTokens(operator, 2, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; @@ -913,26 +901,25 @@ ParseShiftExpr(infoPtr) * * ParseAddExpr -- * - * This procedure parses a Tcl addition expression: + * This function parses a Tcl addition expression: * addExpr ::= multiplyExpr {('+' | '-') multiplyExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseAddExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; @@ -941,7 +928,7 @@ ParseAddExpr(infoPtr) HERE("addExpr", 10); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseMultiplyExpr(infoPtr); if (code != TCL_OK) { return code; @@ -964,7 +951,7 @@ ParseAddExpr(infoPtr) */ PrependSubExprTokens(operator, 1, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; @@ -975,26 +962,25 @@ ParseAddExpr(infoPtr) * * ParseMultiplyExpr -- * - * This procedure parses a Tcl multiply expression: + * This function parses a Tcl multiply expression: * multiplyExpr ::= exponentialExpr {('*' | '/' | '%') exponentialExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseMultiplyExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; @@ -1003,7 +989,7 @@ ParseMultiplyExpr(infoPtr) HERE("multiplyExpr", 11); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseExponentialExpr(infoPtr); if (code != TCL_OK) { return code; @@ -1012,7 +998,7 @@ ParseMultiplyExpr(infoPtr) lexeme = infoPtr->lexeme; while ((lexeme == MULT) || (lexeme == DIVIDE) || (lexeme == MOD)) { operator = infoPtr->start; - code = GetLexeme(infoPtr); /* skip over * or / or % */ + code = GetLexeme(infoPtr); /* skip over * or / or % */ if (code != TCL_OK) { return code; } @@ -1026,7 +1012,7 @@ ParseMultiplyExpr(infoPtr) */ PrependSubExprTokens(operator, 1, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; @@ -1037,26 +1023,25 @@ ParseMultiplyExpr(infoPtr) * * ParseExponentialExpr -- * - * This procedure parses a Tcl exponential expression: + * This function parses a Tcl exponential expression: * exponentialExpr ::= unaryExpr {'**' unaryExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseExponentialExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; @@ -1093,33 +1078,31 @@ ParseExponentialExpr(infoPtr) } return TCL_OK; } - /* *---------------------------------------------------------------------- * * ParseUnaryExpr -- * - * This procedure parses a Tcl unary expression: + * This function parses a Tcl unary expression: * unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseUnaryExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; @@ -1128,10 +1111,10 @@ ParseUnaryExpr(infoPtr) HERE("unaryExpr", 13); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + lexeme = infoPtr->lexeme; if ((lexeme == PLUS) || (lexeme == MINUS) || (lexeme == BIT_NOT) - || (lexeme == NOT)) { + || (lexeme == NOT)) { operator = infoPtr->start; code = GetLexeme(infoPtr); /* skip over the unary operator */ if (code != TCL_OK) { @@ -1147,7 +1130,7 @@ ParseUnaryExpr(infoPtr) */ PrependSubExprTokens(operator, 1, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } else { /* must be a primaryExpr */ code = ParsePrimaryExpr(infoPtr); if (code != TCL_OK) { @@ -1162,27 +1145,26 @@ ParseUnaryExpr(infoPtr) * * ParsePrimaryExpr -- * - * This procedure parses a Tcl primary expression: + * This function parses a Tcl primary expression: * primaryExpr ::= literal | varReference | quotedString | * '[' command ']' | mathFuncCall | '(' condExpr ')' * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParsePrimaryExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; Tcl_Interp *interp = parsePtr->interp; @@ -1232,9 +1214,9 @@ ParsePrimaryExpr(infoPtr) /* * Process the primary then finish setting the fields of the - * TCL_TOKEN_SUB_EXPR token. Note that we can't use the pointer now - * stored in "exprTokenPtr" in the code below since the token array - * might be reallocated. + * TCL_TOKEN_SUB_EXPR token. Note that we can't use the pointer now stored + * in "exprTokenPtr" in the code below since the token array might be + * reallocated. */ firstIndex = parsePtr->numTokens; @@ -1243,8 +1225,8 @@ ParsePrimaryExpr(infoPtr) /* * Int or double number. */ - - tokenizeLiteral: + + tokenizeLiteral: if (parsePtr->numTokens == parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } @@ -1264,10 +1246,10 @@ ParsePrimaryExpr(infoPtr) /* * $var variable reference. */ - + dollarPtr = (infoPtr->next - 1); code = Tcl_ParseVarName(interp, dollarPtr, - (infoPtr->lastChar - dollarPtr), parsePtr, 1); + (infoPtr->lastChar - dollarPtr), parsePtr, 1); if (code != TCL_OK) { return code; } @@ -1276,17 +1258,17 @@ ParsePrimaryExpr(infoPtr) exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; exprTokenPtr->size = parsePtr->tokenPtr[firstIndex].size; exprTokenPtr->numComponents = - (parsePtr->tokenPtr[firstIndex].numComponents + 1); + (parsePtr->tokenPtr[firstIndex].numComponents + 1); break; - + case QUOTE: /* * '"' string '"' */ - + stringStart = infoPtr->next; code = Tcl_ParseQuotedString(interp, infoPtr->start, - (infoPtr->lastChar - stringStart), parsePtr, 1, &termPtr); + (infoPtr->lastChar - stringStart), parsePtr, 1, &termPtr); if (code != TCL_OK) { return code; } @@ -1298,8 +1280,8 @@ ParsePrimaryExpr(infoPtr) /* * If parsing the quoted string resulted in more than one token, - * insert a TCL_TOKEN_WORD token before them. This indicates that - * the quoted string represents a concatenation of multiple tokens. + * insert a TCL_TOKEN_WORD token before them. This indicates that the + * quoted string represents a concatenation of multiple tokens. */ if (exprTokenPtr->numComponents > 1) { @@ -1309,7 +1291,7 @@ ParsePrimaryExpr(infoPtr) tokenPtr = &parsePtr->tokenPtr[firstIndex]; numToMove = (parsePtr->numTokens - firstIndex); memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr, - (size_t) (numToMove * sizeof(Tcl_Token))); + (size_t) (numToMove * sizeof(Tcl_Token))); parsePtr->numTokens++; exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; @@ -1321,7 +1303,7 @@ ParsePrimaryExpr(infoPtr) tokenPtr->numComponents = (exprTokenPtr->numComponents - 1); } break; - + case OPEN_BRACKET: /* * '[' command {command} ']' @@ -1337,10 +1319,10 @@ ParsePrimaryExpr(infoPtr) parsePtr->numTokens++; /* - * Call Tcl_ParseCommand repeatedly to parse the nested command(s) - * to find their end, then throw away that parse information. + * Call Tcl_ParseCommand repeatedly to parse the nested command(s) to + * find their end, then throw away that parse information. */ - + src = infoPtr->next; while (1) { if (Tcl_ParseCommand(interp, src, (parsePtr->end - src), 1, @@ -1353,8 +1335,8 @@ ParsePrimaryExpr(infoPtr) src = (nested.commandStart + nested.commandSize); /* - * This is equivalent to Tcl_FreeParse(&nested), but - * presumably inlined here for sake of runtime optimization + * This is equivalent to Tcl_FreeParse(&nested), but presumably + * inlined here for sake of runtime optimization */ if (nested.tokenPtr != nested.staticTokens) { @@ -1366,7 +1348,7 @@ ParsePrimaryExpr(infoPtr) * It must have been the last character of the parsed command. */ - if ((nested.term < parsePtr->end) && (*nested.term == ']') + if ((nested.term < parsePtr->end) && (*nested.term == ']') && !nested.incomplete) { break; } @@ -1395,8 +1377,7 @@ ParsePrimaryExpr(infoPtr) */ code = Tcl_ParseBraces(interp, infoPtr->start, - (infoPtr->lastChar - infoPtr->start), parsePtr, 1, - &termPtr); + (infoPtr->lastChar - infoPtr->start), parsePtr, 1, &termPtr); if (code != TCL_OK) { return code; } @@ -1408,8 +1389,8 @@ ParsePrimaryExpr(infoPtr) /* * If parsing the braced string resulted in more than one token, - * insert a TCL_TOKEN_WORD token before them. This indicates that - * the braced string represents a concatenation of multiple tokens. + * insert a TCL_TOKEN_WORD token before them. This indicates that the + * braced string represents a concatenation of multiple tokens. */ if (exprTokenPtr->numComponents > 1) { @@ -1419,19 +1400,19 @@ ParsePrimaryExpr(infoPtr) tokenPtr = &parsePtr->tokenPtr[firstIndex]; numToMove = (parsePtr->numTokens - firstIndex); memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr, - (size_t) (numToMove * sizeof(Tcl_Token))); + (size_t) (numToMove * sizeof(Tcl_Token))); parsePtr->numTokens++; exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; exprTokenPtr->numComponents++; - + tokenPtr->type = TCL_TOKEN_WORD; tokenPtr->start = exprTokenPtr->start; tokenPtr->size = exprTokenPtr->size; tokenPtr->numComponents = exprTokenPtr->numComponents-1; } break; - + case STREQ: case STRNEQ: case IN_LIST: @@ -1442,18 +1423,21 @@ ParsePrimaryExpr(infoPtr) */ ParseInfo savedInfo = *infoPtr; - - code = GetLexeme(infoPtr); /* skip over function name */ + + code = GetLexeme(infoPtr); /* skip over function name */ if (code != TCL_OK) { return code; } if (infoPtr->lexeme != OPEN_PAREN) { int code; - Tcl_Obj *errMsg, *objPtr - = Tcl_NewStringObj(savedInfo.start, savedInfo.size); + Tcl_Obj *errMsg, *objPtr = + Tcl_NewStringObj(savedInfo.start, savedInfo.size); + + /* + * Check for boolean literals (true, false, yes, no, on, off). + */ - /* Check for boolean literals (true, false, yes, no, on, off) */ Tcl_IncrRefCount(objPtr); code = Tcl_ConvertToType(NULL, objPtr, &tclBooleanType); Tcl_DecrRefCount(objPtr); @@ -1461,27 +1445,23 @@ ParsePrimaryExpr(infoPtr) *infoPtr = savedInfo; goto tokenizeLiteral; } - + /* - * Either there's a math function without a (, or a - * variable name without a '$'. + * Either there's a math function without a (, or a variable name + * without a '$'. */ errMsg = Tcl_NewStringObj( "syntax error in expression \"", -1 ); - TclAppendLimitedToObj( errMsg, - infoPtr->originalExpr, - (int) (infoPtr->lastChar - - infoPtr->originalExpr ), - 63, - NULL ); - Tcl_AppendToObj( errMsg, "\": the word \"", -1 ); - Tcl_AppendToObj( errMsg, savedInfo.start, savedInfo.size ); - Tcl_AppendToObj( errMsg, - "\" requires a preceding $ if it's a variable ", - -1 ); - Tcl_AppendToObj( errMsg, - "or function arguments if it's a function", -1 ); - Tcl_SetObjResult( infoPtr->parsePtr->interp, errMsg ); + TclAppendLimitedToObj(errMsg, infoPtr->originalExpr, + (int) (infoPtr->lastChar - infoPtr->originalExpr), + 63, NULL); + Tcl_AppendToObj(errMsg, "\": the word \"", -1); + Tcl_AppendToObj(errMsg, savedInfo.start, savedInfo.size); + Tcl_AppendToObj(errMsg, + "\" requires a preceding $ if it's a variable ", -1); + Tcl_AppendToObj(errMsg, + "or function arguments if it's a function", -1); + Tcl_SetObjResult(infoPtr->parsePtr->interp, errMsg); infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX; infoPtr->parsePtr->term = infoPtr->start; return TCL_ERROR; @@ -1497,8 +1477,8 @@ ParsePrimaryExpr(infoPtr) tokenPtr->size = savedInfo.size; tokenPtr->numComponents = 0; parsePtr->numTokens++; - - code = GetLexeme(infoPtr); /* skip over '(' */ + + code = GetLexeme(infoPtr); /* skip over '(' */ if (code != TCL_OK) { return code; } @@ -1508,7 +1488,7 @@ ParsePrimaryExpr(infoPtr) if (code != TCL_OK) { return code; } - + if (infoPtr->lexeme == COMMA) { code = GetLexeme(infoPtr); /* skip over , */ if (code != TCL_OK) { @@ -1535,7 +1515,8 @@ ParsePrimaryExpr(infoPtr) LogSyntaxError(infoPtr, "premature end of expression"); return TCL_ERROR; case UNKNOWN: - LogSyntaxError(infoPtr, "single equality character not legal in expressions"); + LogSyntaxError(infoPtr, + "single equality character not legal in expressions"); return TCL_ERROR; case UNKNOWN_CHAR: LogSyntaxError(infoPtr, "character not legal in expressions"); @@ -1550,19 +1531,20 @@ ParsePrimaryExpr(infoPtr) LogSyntaxError(infoPtr, "unexpected close parenthesis"); return TCL_ERROR; - default: { - char buf[64]; + default: + { + char buf[64]; - sprintf(buf, "unexpected operator %s", lexemeStrings[lexeme]); - LogSyntaxError(infoPtr, buf); - return TCL_ERROR; + sprintf(buf, "unexpected operator %s", lexemeStrings[lexeme]); + LogSyntaxError(infoPtr, buf); + return TCL_ERROR; } } /* * Advance to the next lexeme before returning. */ - + code = GetLexeme(infoPtr); if (code != TCL_OK) { return code; @@ -1576,25 +1558,24 @@ ParsePrimaryExpr(infoPtr) * * GetLexeme -- * - * Lexical scanner for Tcl expressions: scans a single operator or - * other syntactic element from an expression string. + * Lexical scanner for Tcl expressions: scans a single operator or other + * syntactic element from an expression string. * * Results: * TCL_OK is returned unless an error occurred. In that case a standard * Tcl error code is returned and, if infoPtr->parsePtr->interp is - * non-NULL, the interpreter's result is set to hold an error - * message. TCL_ERROR is returned if an integer overflow, or a - * floating-point overflow or underflow occurred while reading in a - * number. If the lexical analysis is successful, infoPtr->lexeme - * refers to the next symbol in the expression string, and - * infoPtr->next is advanced past the lexeme. Also, if the lexeme is a - * LITERAL or FUNC_NAME, then infoPtr->start is set to the first - * character of the lexeme; otherwise it is set NULL. + * non-NULL, the interpreter's result is set to hold an error message. + * TCL_ERROR is returned if an integer overflow, or a floating-point + * overflow or underflow occurred while reading in a number. If the + * lexical analysis is successful, infoPtr->lexeme refers to the next + * symbol in the expression string, and infoPtr->next is advanced past + * the lexeme. Also, if the lexeme is a LITERAL or FUNC_NAME, then + * infoPtr->start is set to the first character of the lexeme; otherwise + * it is set NULL. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed.. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed.. * *---------------------------------------------------------------------- */ @@ -1612,24 +1593,28 @@ GetLexeme(infoPtr) Tcl_UniChar ch; /* - * Record where the previous lexeme ended. Since we always read one - * lexeme ahead during parsing, this helps us know the source length of + * Record where the previous lexeme ended. Since we always read one lexeme + * ahead during parsing, this helps us know the source length of * subexpression tokens. */ infoPtr->prevEnd = infoPtr->next; /* - * Scan over leading white space at the start of a lexeme. + * Scan over leading white space at the start of a lexeme. */ src = infoPtr->next; numBytes = parsePtr->end - src; + do { char type; int scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type); - src += scanned; numBytes -= scanned; + + src += scanned; + numBytes -= scanned; } while (numBytes && (*src == '\n') && (src++,numBytes--)); + parsePtr->term = src; if (numBytes == 0) { infoPtr->lexeme = END; @@ -1638,20 +1623,21 @@ GetLexeme(infoPtr) } /* - * Try to parse the lexeme first as an integer or floating-point - * number. Don't check for a number if the first character c is - * "+" or "-". If we did, we might treat a binary operator as unary - * by mistake, which would eventually cause a syntax error. + * Try to parse the lexeme first as an integer or floating-point number. + * Don't check for a number if the first character c is "+" or "-". If we + * did, we might treat a binary operator as unary by mistake, which would + * eventually cause a syntax error. */ c = *src; if ((c != '+') && (c != '-')) { CONST char *end = infoPtr->lastChar; - if ((length = TclParseInteger(src, (end - src)))) { + if ((length = TclParseInteger(src, end-src))) { /* - * First length bytes look like an integer. Verify by - * attempting the conversion to the largest integer we have. + * First length bytes look like an integer. Verify by attempting + * the conversion to the largest integer we have. */ + int code; Tcl_WideInt wide; Tcl_Obj *value = Tcl_NewStringObj(src, length); @@ -1663,19 +1649,19 @@ GetLexeme(infoPtr) parsePtr->errorType = TCL_PARSE_BAD_NUMBER; return TCL_ERROR; } - infoPtr->lexeme = LITERAL; + infoPtr->lexeme = LITERAL; infoPtr->start = src; infoPtr->size = length; - infoPtr->next = (src + length); + infoPtr->next = (src + length); parsePtr->term = infoPtr->next; - return TCL_OK; + return TCL_OK; } else if ((length = ParseMaxDoubleLength(src, end))) { /* - * There are length characters that could be a double. - * Let strtod() tells us for sure. Need a writable copy - * so we can set an terminating NULL to keep strtod from - * scanning too far. + * There are length characters that could be a double. Let + * strtod() tells us for sure. Need a writable copy so we can set + * an terminating NULL to keep strtod from scanning too far. */ + char *startPtr; CONST char *termPtr; double doubleValue; @@ -1687,12 +1673,10 @@ GetLexeme(infoPtr) doubleValue = TclStrToD(startPtr, &termPtr); Tcl_DStringFree(&toParse); if (termPtr != startPtr) { - /* - * startPtr was the start of a valid double, copied - * from src. - */ - + * startPtr was the start of a valid double, copied from src. + */ + infoPtr->lexeme = LITERAL; infoPtr->start = src; if ((termPtr - startPtr) > length) { @@ -1716,232 +1700,235 @@ GetLexeme(infoPtr) infoPtr->size = 1; infoPtr->next = src+1; parsePtr->term = infoPtr->next; - - switch (*src) { - case '[': - infoPtr->lexeme = OPEN_BRACKET; - return TCL_OK; - - case '{': - infoPtr->lexeme = OPEN_BRACE; - return TCL_OK; - case '(': - infoPtr->lexeme = OPEN_PAREN; - return TCL_OK; + switch (*src) { + case '[': + infoPtr->lexeme = OPEN_BRACKET; + return TCL_OK; - case ')': - infoPtr->lexeme = CLOSE_PAREN; - return TCL_OK; + case '{': + infoPtr->lexeme = OPEN_BRACE; + return TCL_OK; - case '$': - infoPtr->lexeme = DOLLAR; - return TCL_OK; + case '(': + infoPtr->lexeme = OPEN_PAREN; + return TCL_OK; - case '\"': - infoPtr->lexeme = QUOTE; - return TCL_OK; + case ')': + infoPtr->lexeme = CLOSE_PAREN; + return TCL_OK; - case ',': - infoPtr->lexeme = COMMA; - return TCL_OK; + case '$': + infoPtr->lexeme = DOLLAR; + return TCL_OK; - case '*': - infoPtr->lexeme = MULT; - if ((infoPtr->lastChar - src)>1 && src[1]=='*') { - infoPtr->lexeme = EXPON; - infoPtr->size = 2; - infoPtr->next = src+2; - parsePtr->term = infoPtr->next; - } - return TCL_OK; + case '\"': + infoPtr->lexeme = QUOTE; + return TCL_OK; - case '/': - infoPtr->lexeme = DIVIDE; - return TCL_OK; + case ',': + infoPtr->lexeme = COMMA; + return TCL_OK; - case '%': - infoPtr->lexeme = MOD; - return TCL_OK; + case '*': + infoPtr->lexeme = MULT; + if ((infoPtr->lastChar - src)>1 && src[1]=='*') { + infoPtr->lexeme = EXPON; + infoPtr->size = 2; + infoPtr->next = src+2; + parsePtr->term = infoPtr->next; + } + return TCL_OK; - case '+': - infoPtr->lexeme = PLUS; - return TCL_OK; + case '/': + infoPtr->lexeme = DIVIDE; + return TCL_OK; - case '-': - infoPtr->lexeme = MINUS; - return TCL_OK; + case '%': + infoPtr->lexeme = MOD; + return TCL_OK; - case '?': - infoPtr->lexeme = QUESTY; - return TCL_OK; + case '+': + infoPtr->lexeme = PLUS; + return TCL_OK; - case ':': - infoPtr->lexeme = COLON; - return TCL_OK; + case '-': + infoPtr->lexeme = MINUS; + return TCL_OK; - case '<': - infoPtr->lexeme = LESS; - if ((infoPtr->lastChar - src) > 1) { - switch (src[1]) { - case '<': - infoPtr->lexeme = LEFT_SHIFT; - infoPtr->size = 2; - infoPtr->next = src+2; - break; - case '=': - infoPtr->lexeme = LEQ; - infoPtr->size = 2; - infoPtr->next = src+2; - break; - } - } - parsePtr->term = infoPtr->next; - return TCL_OK; + case '?': + infoPtr->lexeme = QUESTY; + return TCL_OK; - case '>': - infoPtr->lexeme = GREATER; - if ((infoPtr->lastChar - src) > 1) { - switch (src[1]) { - case '>': - infoPtr->lexeme = RIGHT_SHIFT; - infoPtr->size = 2; - infoPtr->next = src+2; - break; - case '=': - infoPtr->lexeme = GEQ; - infoPtr->size = 2; - infoPtr->next = src+2; - break; - } - } - parsePtr->term = infoPtr->next; - return TCL_OK; + case ':': + infoPtr->lexeme = COLON; + return TCL_OK; - case '=': - infoPtr->lexeme = UNKNOWN; - if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) { - infoPtr->lexeme = EQUAL; + case '<': + infoPtr->lexeme = LESS; + if ((infoPtr->lastChar - src) > 1) { + switch (src[1]) { + case '<': + infoPtr->lexeme = LEFT_SHIFT; infoPtr->size = 2; infoPtr->next = src+2; - } - parsePtr->term = infoPtr->next; - return TCL_OK; - - case '!': - infoPtr->lexeme = NOT; - if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) { - infoPtr->lexeme = NEQ; + break; + case '=': + infoPtr->lexeme = LEQ; infoPtr->size = 2; infoPtr->next = src+2; + break; } - parsePtr->term = infoPtr->next; - return TCL_OK; + } + parsePtr->term = infoPtr->next; + return TCL_OK; - case '&': - infoPtr->lexeme = BIT_AND; - if ((src[1] == '&') && ((infoPtr->lastChar - src) > 1)) { - infoPtr->lexeme = AND; + case '>': + infoPtr->lexeme = GREATER; + if ((infoPtr->lastChar - src) > 1) { + switch (src[1]) { + case '>': + infoPtr->lexeme = RIGHT_SHIFT; + infoPtr->size = 2; + infoPtr->next = src+2; + break; + case '=': + infoPtr->lexeme = GEQ; infoPtr->size = 2; infoPtr->next = src+2; + break; } + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '=': + infoPtr->lexeme = UNKNOWN; + if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) { + infoPtr->lexeme = EQUAL; + infoPtr->size = 2; + infoPtr->next = src+2; + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '!': + infoPtr->lexeme = NOT; + if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) { + infoPtr->lexeme = NEQ; + infoPtr->size = 2; + infoPtr->next = src+2; + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '&': + infoPtr->lexeme = BIT_AND; + if ((src[1] == '&') && ((infoPtr->lastChar - src) > 1)) { + infoPtr->lexeme = AND; + infoPtr->size = 2; + infoPtr->next = src+2; + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '^': + infoPtr->lexeme = BIT_XOR; + return TCL_OK; + + case '|': + infoPtr->lexeme = BIT_OR; + if ((src[1] == '|') && ((infoPtr->lastChar - src) > 1)) { + infoPtr->lexeme = OR; + infoPtr->size = 2; + infoPtr->next = src+2; + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '~': + infoPtr->lexeme = BIT_NOT; + return TCL_OK; + + case 'e': + if ((src[1] == 'q') && ((infoPtr->lastChar - src) > 1) && + (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { + infoPtr->lexeme = STREQ; + infoPtr->size = 2; + infoPtr->next = src+2; parsePtr->term = infoPtr->next; return TCL_OK; + } else { + goto checkFuncName; + } - case '^': - infoPtr->lexeme = BIT_XOR; + case 'n': + if ((src[1] == 'e') && ((infoPtr->lastChar - src) > 1) && + (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { + infoPtr->lexeme = STRNEQ; + infoPtr->size = 2; + infoPtr->next = src+2; + parsePtr->term = infoPtr->next; return TCL_OK; - - case '|': - infoPtr->lexeme = BIT_OR; - if ((src[1] == '|') && ((infoPtr->lastChar - src) > 1)) { - infoPtr->lexeme = OR; - infoPtr->size = 2; - infoPtr->next = src+2; - } + } else if ((src[1] == 'i') && ((infoPtr->lastChar - src) > 1) && + (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { + infoPtr->lexeme = NOT_IN_LIST; + infoPtr->size = 2; + infoPtr->next = src+2; parsePtr->term = infoPtr->next; return TCL_OK; + } else { + goto checkFuncName; + } - case '~': - infoPtr->lexeme = BIT_NOT; + case 'i': + if ((src[1] == 'n') && ((infoPtr->lastChar - src) > 1) && + (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { + infoPtr->lexeme = IN_LIST; + infoPtr->size = 2; + infoPtr->next = src+2; + parsePtr->term = infoPtr->next; return TCL_OK; + } else { + goto checkFuncName; + } - case 'e': - if ((src[1] == 'q') && ((infoPtr->lastChar - src) > 1) && - (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { - infoPtr->lexeme = STREQ; - infoPtr->size = 2; - infoPtr->next = src+2; - parsePtr->term = infoPtr->next; - return TCL_OK; - } else { - goto checkFuncName; - } - - case 'n': - if ((src[1] == 'e') && ((infoPtr->lastChar - src) > 1) && - (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { - infoPtr->lexeme = STRNEQ; - infoPtr->size = 2; - infoPtr->next = src+2; - parsePtr->term = infoPtr->next; - return TCL_OK; - } else if ((src[1] == 'i') && ((infoPtr->lastChar - src) > 1) && - (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { - infoPtr->lexeme = NOT_IN_LIST; - infoPtr->size = 2; - infoPtr->next = src+2; - parsePtr->term = infoPtr->next; - return TCL_OK; - } else { - goto checkFuncName; - } + default: + checkFuncName: + length = (infoPtr->lastChar - src); + if (Tcl_UtfCharComplete(src, length)) { + offset = Tcl_UtfToUniChar(src, &ch); + } else { + char utfBytes[TCL_UTF_MAX]; - case 'i': - if ((src[1] == 'n') && ((infoPtr->lastChar - src) > 1) && - (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { - infoPtr->lexeme = IN_LIST; - infoPtr->size = 2; - infoPtr->next = src+2; - parsePtr->term = infoPtr->next; - return TCL_OK; - } else { - goto checkFuncName; - } + memcpy(utfBytes, src, (size_t) length); + utfBytes[length] = '\0'; + offset = Tcl_UtfToUniChar(utfBytes, &ch); + } + c = UCHAR(ch); + if (isalpha(UCHAR(c))) { /* INTL: ISO only. */ + infoPtr->lexeme = FUNC_NAME; + while (isalnum(UCHAR(c)) || (c == '_')) { /* INTL: ISO only. */ + src += offset; + length -= offset; + if (Tcl_UtfCharComplete(src, length)) { + offset = Tcl_UtfToUniChar(src, &ch); + } else { + char utfBytes[TCL_UTF_MAX]; - default: - checkFuncName: - length = (infoPtr->lastChar - src); - if (Tcl_UtfCharComplete(src, length)) { - offset = Tcl_UtfToUniChar(src, &ch); - } else { - char utfBytes[TCL_UTF_MAX]; - memcpy(utfBytes, src, (size_t) length); - utfBytes[length] = '\0'; - offset = Tcl_UtfToUniChar(utfBytes, &ch); - } - c = UCHAR(ch); - if (isalpha(UCHAR(c))) { /* INTL: ISO only. */ - infoPtr->lexeme = FUNC_NAME; - while (isalnum(UCHAR(c)) || (c == '_')) { /* INTL: ISO only. */ - src += offset; length -= offset; - if (Tcl_UtfCharComplete(src, length)) { - offset = Tcl_UtfToUniChar(src, &ch); - } else { - char utfBytes[TCL_UTF_MAX]; - memcpy(utfBytes, src, (size_t) length); - utfBytes[length] = '\0'; - offset = Tcl_UtfToUniChar(utfBytes, &ch); - } - c = UCHAR(ch); + memcpy(utfBytes, src, (size_t) length); + utfBytes[length] = '\0'; + offset = Tcl_UtfToUniChar(utfBytes, &ch); } - infoPtr->size = (src - infoPtr->start); - infoPtr->next = src; - parsePtr->term = infoPtr->next; - return TCL_OK; + c = UCHAR(ch); } - infoPtr->lexeme = UNKNOWN_CHAR; + infoPtr->size = (src - infoPtr->start); + infoPtr->next = src; + parsePtr->term = infoPtr->next; return TCL_OK; + } + infoPtr->lexeme = UNKNOWN_CHAR; + return TCL_OK; } } @@ -1950,14 +1937,14 @@ GetLexeme(infoPtr) * * TclParseInteger -- * - * Scans up to numBytes bytes starting at src, and checks whether - * the leading bytes look like an integer's string representation. + * Scans up to numBytes bytes starting at src, and checks whether the + * leading bytes look like an integer's string representation. * * Results: * Returns 0 if the leading bytes do not look like an integer. - * Otherwise, returns the number of bytes examined that look - * like an integer. This may be less than numBytes if the integer - * is only the leading part of the string. + * Otherwise, returns the number of bytes examined that look like an + * integer. This may be less than numBytes if the integer is only the + * leading part of the string. * * Side effects: * None. @@ -1972,27 +1959,35 @@ TclParseInteger(string, numBytes) { register CONST char *p = string; - /* Take care of introductory "0x" */ + /* + * Take care of introductory "0x". + */ + if ((numBytes > 1) && (p[0] == '0') && ((p[1] == 'x') || (p[1] == 'X'))) { int scanned; Tcl_UniChar ch; - p+=2; numBytes -= 2; + + p += 2; + numBytes -= 2; scanned = TclParseHex(p, numBytes, &ch); if (scanned) { - return scanned + 2; + return scanned+2; } - /* Recognize the 0 as valid integer, but x is left behind */ + /* + * Recognize the 0 as valid integer, but x is left behind. + */ + return 1; } - while (numBytes && isdigit(UCHAR(*p))) { /* INTL: digit */ + while (numBytes && isdigit(UCHAR(*p))) { /* INTL: digit */ numBytes--; p++; } if (numBytes == 0) { - return (p - string); + return (p - string); } if ((*p != '.') && (*p != 'e') && (*p != 'E')) { - return (p - string); + return (p - string); } return 0; } @@ -2002,20 +1997,18 @@ TclParseInteger(string, numBytes) * * ParseMaxDoubleLength -- * - * Scans a sequence of bytes checking that the characters could - * be in a string rep of a double. + * Scans a sequence of bytes checking that the characters could be in a + * string rep of a double. * * Results: - * Returns the number of bytes starting with string, runing to, but - * not including end, all of which could be part of a string rep. - * of a double. Only character identity is used, no actual - * parsing is done. + * Returns the number of bytes starting with string, running to, but not + * including end, all of which could be part of a string rep. of a + * double. Only character identity is used, no actual parsing is done. * - * The legal bytes are '0' - '9', 'A' - 'F', 'a' - 'f', - * '.', '+', '-', 'i', 'I', 'n', 'N', 'p', 'P', 'x', and 'X'. - * This covers the values "Inf" and "Nan" as well as the - * decimal and hexadecimal representations recognized by a - * C99-compliant strtod(). + * The legal bytes are '0' - '9', 'A' - 'F', 'a' - 'f', '.', '+', '-', + * 'i', 'I', 'n', 'N', 'p', 'P', 'x', and 'X'. This covers the values + * "Inf" and "Nan" as well as the decimal and hexadecimal representations + * recognized by a C99-compliant strtod(). * * Side effects: * None. @@ -2032,19 +2025,19 @@ ParseMaxDoubleLength(string, end) CONST char *p = string; while (p < end) { switch (*p) { - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': case 'A': case 'B': - case 'C': case 'D': case 'E': case 'F': case 'I': case 'N': - case 'P': case 'X': case 'a': case 'b': case 'c': case 'd': - case 'e': case 'f': case 'i': case 'n': case 'p': case 'x': - case '.': case '+': case '-': case '(': case ' ': case ')': - p++; - break; - default: - goto done; + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': case 'A': case 'B': + case 'C': case 'D': case 'E': case 'F': case 'I': case 'N': + case 'P': case 'X': case 'a': case 'b': case 'c': case 'd': + case 'e': case 'f': case 'i': case 'n': case 'p': case 'x': + case '.': case '+': case '-': case '(': case ' ': case ')': + p++; + break; + default: + goto done; } } - done: + done: return (p - string); } @@ -2053,7 +2046,7 @@ ParseMaxDoubleLength(string, end) * * PrependSubExprTokens -- * - * This procedure is called after the operands of an subexpression have + * This function is called after the operands of an subexpression have * been parsed. It generates two tokens: a TCL_TOKEN_SUB_EXPR token for * the subexpression, and a TCL_TOKEN_OPERATOR token for its operator. * These two tokens are inserted before the operand tokens. @@ -2070,8 +2063,8 @@ ParseMaxDoubleLength(string, end) static void PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr) - CONST char *op; /* Points to first byte of the operator - * in the source script. */ + CONST char *op; /* Points to first byte of the operator in the + * source script. */ int opBytes; /* Number of bytes in the operator. */ CONST char *src; /* Points to first byte of the subexpression * in the source script. */ @@ -2079,8 +2072,8 @@ PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr) * source. */ int firstIndex; /* Index of first token already emitted for * operator's first (or only) operand. */ - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; Tcl_Token *tokenPtr, *firstTokenPtr; @@ -2093,15 +2086,15 @@ PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr) tokenPtr = (firstTokenPtr + 2); numToMove = (parsePtr->numTokens - firstIndex); memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr, - (size_t) (numToMove * sizeof(Tcl_Token))); + (size_t) (numToMove * sizeof(Tcl_Token))); parsePtr->numTokens += 2; - + tokenPtr = firstTokenPtr; tokenPtr->type = TCL_TOKEN_SUB_EXPR; tokenPtr->start = src; tokenPtr->size = srcBytes; tokenPtr->numComponents = parsePtr->numTokens - (firstIndex + 1); - + tokenPtr++; tokenPtr->type = TCL_TOKEN_OPERATOR; tokenPtr->start = op; @@ -2114,7 +2107,7 @@ PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr) * * LogSyntaxError -- * - * This procedure is invoked after an error occurs when parsing an + * This function is invoked after an error occurs when parsing an * expression. It sets the interpreter result to an error message * describing the error. * @@ -2123,25 +2116,33 @@ PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr) * * Side effects: * Sets the interpreter result to an error message describing the - * expression that was being parsed when the error occurred, and why - * the parser considers that to be a syntax error at all. + * expression that was being parsed when the error occurred, and why the + * parser considers that to be a syntax error at all. * *---------------------------------------------------------------------- */ static void LogSyntaxError(infoPtr, extraInfo) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ - CONST char *extraInfo; /* String to provide extra information - * about the syntax error. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ + CONST char *extraInfo; /* String to provide extra information about + * the syntax error. */ { Tcl_Obj *result = Tcl_NewStringObj("syntax error in expression \"", -1); - TclAppendLimitedToObj(result, infoPtr->originalExpr, + TclAppendLimitedToObj(result, infoPtr->originalExpr, (int)(infoPtr->lastChar - infoPtr->originalExpr), 63, NULL); Tcl_AppendStringsToObj(result, "\": ", extraInfo, (char *) NULL); Tcl_SetObjResult(infoPtr->parsePtr->interp, result); infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX; infoPtr->parsePtr->term = infoPtr->start; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 08491cc..362d489 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -1,23 +1,23 @@ -/* +/* * tclPathObj.c -- * - * This file contains the implementation of Tcl's "path" object - * type used to represent and manipulate a general (virtual) - * filesystem entity in an efficient manner. + * This file contains the implementation of Tcl's "path" object type used + * to represent and manipulate a general (virtual) filesystem entity in + * an efficient manner. * * Copyright (c) 2003 Vince Darley. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPathObj.c,v 1.41 2005/05/10 18:34:47 kennykb Exp $ + * RCS: @(#) $Id: tclPathObj.c,v 1.42 2005/07/21 14:38:50 dkf Exp $ */ #include "tclInt.h" #include "tclFileSystem.h" /* - * Prototypes for procedures defined later in this file. + * Prototypes for functions defined later in this file. */ static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, @@ -27,80 +27,76 @@ static void UpdateStringOfFsPath _ANSI_ARGS_((Tcl_Obj *pathPtr)); static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr)); static int FindSplitPos _ANSI_ARGS_((CONST char *path, int separator)); -static int IsSeparatorOrNull _ANSI_ARGS_((int ch)); +static int IsSeparatorOrNull _ANSI_ARGS_((int ch)); static Tcl_Obj* GetExtension _ANSI_ARGS_((Tcl_Obj *pathPtr)); /* - * Define the 'path' object type, which Tcl uses to represent - * file paths internally. + * Define the 'path' object type, which Tcl uses to represent file paths + * internally. */ Tcl_ObjType tclFsPathType = { "path", /* name */ FreeFsPathInternalRep, /* freeIntRepProc */ - DupFsPathInternalRep, /* dupIntRepProc */ + DupFsPathInternalRep, /* dupIntRepProc */ UpdateStringOfFsPath, /* updateStringProc */ SetFsPathFromAny /* setFromAnyProc */ }; -/* +/* * struct FsPath -- - * - * Internal representation of a Tcl_Obj of "path" type. This - * can be used to represent relative or absolute paths, and has - * certain optimisations when used to represent paths which are - * already normalized and absolute. - * - * Note that both 'translatedPathPtr' and 'normPathPtr' can be a - * circular reference to the container Tcl_Obj of this FsPath. - * + * + * Internal representation of a Tcl_Obj of "path" type. This can be used to + * represent relative or absolute paths, and has certain optimisations when + * used to represent paths which are already normalized and absolute. + * + * Note that both 'translatedPathPtr' and 'normPathPtr' can be a circular + * reference to the container Tcl_Obj of this FsPath. + * * There are two cases, with the first being the most common: - * - * (i) flags == 0, => Ordinary path. - * - * translatedPathPtr contains the translated path (which may be - * a circular reference to the object itself). If it is NULL - * then the path is pure normalized (and the normPathPtr will be - * a circular reference). cwdPtr is null for an absolute path, - * and non-null for a relative path (unless the cwd has never been - * set, in which case the cwdPtr may also be null for a relative path). - * + * + * (i) flags == 0, => Ordinary path. + * + * translatedPathPtr contains the translated path (which may be a circular + * reference to the object itself). If it is NULL then the path is pure + * normalized (and the normPathPtr will be a circular reference). cwdPtr is + * null for an absolute path, and non-null for a relative path (unless the cwd + * has never been set, in which case the cwdPtr may also be null for a + * relative path). + * * (ii) flags != 0, => Special path, see TclNewFSPathObj - * - * Now, this is a path like 'file join $dir $tail' where, cwdPtr is - * the $dir and normPathPtr is the $tail. - * + * + * Now, this is a path like 'file join $dir $tail' where, cwdPtr is the $dir + * and normPathPtr is the $tail. + * */ typedef struct FsPath { - Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences. - * If this is NULL, then this is a - * pure normalized, absolute path - * object, in which the parent Tcl_Obj's - * string rep is already both translated - * and normalized. */ - Tcl_Obj *normPathPtr; /* Normalized absolute path, without - * ., .. or ~user sequences. If the - * Tcl_Obj containing - * this FsPath is already normalized, - * this may be a circular reference back - * to the container. If that is NOT the - * case, we have a refCount on the object. */ - Tcl_Obj *cwdPtr; /* If null, path is absolute, else - * this points to the cwd object used - * for this path. We have a refCount - * on the object. */ - int flags; /* Flags to describe interpretation - - * see below. */ - ClientData nativePathPtr; /* Native representation of this path, - * which is filesystem dependent. */ - int filesystemEpoch; /* Used to ensure the path representation - * was generated during the correct - * filesystem epoch. The epoch changes - * when filesystem-mounts are changed. */ + Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences. If this + * is NULL, then this is a pure normalized, + * absolute path object, in which the parent + * Tcl_Obj's string rep is already both + * translated and normalized. */ + Tcl_Obj *normPathPtr; /* Normalized absolute path, without ., .. or + * ~user sequences. If the Tcl_Obj containing + * this FsPath is already normalized, this may + * be a circular reference back to the + * container. If that is NOT the case, we have + * a refCount on the object. */ + Tcl_Obj *cwdPtr; /* If null, path is absolute, else this points + * to the cwd object used for this path. We + * have a refCount on the object. */ + int flags; /* Flags to describe interpretation - see + * below. */ + ClientData nativePathPtr; /* Native representation of this path, which + * is filesystem dependent. */ + int filesystemEpoch; /* Used to ensure the path representation was + * generated during the correct filesystem + * epoch. The epoch changes when + * filesystem-mounts are changed. */ struct FilesystemRecord *fsRecPtr; - /* Pointer to the filesystem record - * entry to use for this path. */ + /* Pointer to the filesystem record entry to + * use for this path. */ } FsPath; /* @@ -109,9 +105,9 @@ typedef struct FsPath { #define TCLPATH_APPENDED 1 -/* - * Define some macros to give us convenient access to path-object - * specific fields. +/* + * Define some macros to give us convenient access to path-object specific + * fields. */ #define PATHOBJ(pathPtr) (pathPtr->internalRep.otherValuePtr) @@ -124,82 +120,78 @@ typedef struct FsPath { * * TclFSNormalizeAbsolutePath -- * - * Description: - * Takes an absolute path specification and computes a 'normalized' - * path from it. - * - * A normalized path is one which has all '../', './' removed. - * Also it is one which is in the 'standard' format for the native - * platform. On Unix, this means the path must be free of - * symbolic links/aliases, and on Windows it means we want the - * long form, with that long form's case-dependence (which gives - * us a unique, case-dependent path). - * - * The behaviour of this function if passed a non-absolute path - * is NOT defined. - * - * pathPtr may have a refCount of zero, or may be a shared - * object. + * Takes an absolute path specification and computes a 'normalized' path + * from it. + * + * A normalized path is one which has all '../', './' removed. Also it + * is one which is in the 'standard' format for the native platform. On + * Unix, this means the path must be free of symbolic links/aliases, and + * on Windows it means we want the long form, with that long form's + * case-dependence (which gives us a unique, case-dependent path). + * + * The behaviour of this function if passed a non-absolute path is NOT + * defined. + * + * pathPtr may have a refCount of zero, or may be a shared object. * * Results: - * The result is returned in a Tcl_Obj with a refCount of 1, - * which is therefore owned by the caller. It must be - * freed (with Tcl_DecrRefCount) by the caller when no longer needed. + * The result is returned in a Tcl_Obj with a refCount of 1, which is + * therefore owned by the caller. It must be freed (with + * Tcl_DecrRefCount) by the caller when no longer needed. * * Side effects: * None (beyond the memory allocation for the result). * * Special note: * This code was originally based on code from Matt Newman and - * Jean-Claude Wippler, but has since been totally rewritten by - * Vince Darley to deal with symbolic links. + * Jean-Claude Wippler, but has since been totally rewritten by Vince + * Darley to deal with symbolic links. * *--------------------------------------------------------------------------- */ Tcl_Obj* TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) - Tcl_Interp* interp; /* Interpreter to use */ - Tcl_Obj *pathPtr; /* Absolute path to normalize */ - ClientData *clientDataPtr; /* If non-NULL, then may be set to the - * fs-specific clientData for this path. - * This will happen when that extra - * information can be calculated efficiently - * as a side-effect of normalization. */ + Tcl_Interp* interp; /* Interpreter to use */ + Tcl_Obj *pathPtr; /* Absolute path to normalize */ + ClientData *clientDataPtr; /* If non-NULL, then may be set to the + * fs-specific clientData for this path. This + * will happen when that extra information can + * be calculated efficiently as a side-effect + * of normalization. */ { ClientData clientData = NULL; CONST char *dirSep, *oldDirSep; - int first = 1; /* Set to zero once we've passed the first - * directory separator - we can't use '..' to - * remove the volume in a path. */ + int first = 1; /* Set to zero once we've passed the first + * directory separator - we can't use '..' to + * remove the volume in a path. */ Tcl_Obj *retVal = NULL; dirSep = TclGetString(pathPtr); - + if (tclPlatform == TCL_PLATFORM_WINDOWS) { - if (dirSep[0] != 0 && dirSep[1] == ':' && - (dirSep[2] == '/' || dirSep[2] == '\\')) { + if (dirSep[0] != 0 && dirSep[1] == ':' && + (dirSep[2] == '/' || dirSep[2] == '\\')) { /* Do nothing */ - } else if ((dirSep[0] == '/' || dirSep[0] == '\\') - && (dirSep[1] == '/' || dirSep[1] == '\\')) { - /* - * UNC style path, where we must skip over the - * first separator, since the first two segments - * are actually inseparable. + } else if ((dirSep[0] == '/' || dirSep[0] == '\\') + && (dirSep[1] == '/' || dirSep[1] == '\\')) { + /* + * UNC style path, where we must skip over the first separator, + * since the first two segments are actually inseparable. */ + dirSep += 2; dirSep += FindSplitPos(dirSep, '/'); if (*dirSep != 0) { - dirSep++; + dirSep++; } } } - - /* - * Scan forward from one directory separator to the next, - * checking for '..' and '.' sequences which must be handled - * specially. In particular handling of '..' can be complicated - * if the directory before is a link, since we will have to - * expand the link to be able to back up one level. + + /* + * Scan forward from one directory separator to the next, checking for + * '..' and '.' sequences which must be handled specially. In particular + * handling of '..' can be complicated if the directory before is a link, + * since we will have to expand the link to be able to back up one level. */ while (*dirSep != 0) { @@ -207,7 +199,7 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) if (!first) { dirSep++; } - dirSep += FindSplitPos(dirSep, '/'); + dirSep += FindSplitPos(dirSep, '/'); if (dirSep[0] == 0 || dirSep[1] == 0) { if (retVal != NULL) { Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep); @@ -219,9 +211,12 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep); oldDirSep = dirSep; } - again: + again: if (IsSeparatorOrNull(dirSep[2])) { - /* Need to skip '.' in the path */ + /* + * Need to skip '.' in the path. + */ + if (retVal == NULL) { CONST char *path = TclGetString(pathPtr); retVal = Tcl_NewStringObj(path, dirSep - path); @@ -238,7 +233,11 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) Tcl_Obj *link; int curLen; char *linkStr; - /* Have '..' so need to skip previous directory */ + + /* + * Have '..' so need to skip previous directory. + */ + if (retVal == NULL) { CONST char *path = TclGetString(pathPtr); retVal = Tcl_NewStringObj(path, dirSep - path); @@ -247,35 +246,38 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) { link = Tcl_FSLink(retVal, NULL, 0); if (link != NULL) { - /* - * Got a link. Need to check if the link - * is relative or absolute, for those platforms - * where relative links exist. + /* + * Got a link. Need to check if the link is relative + * or absolute, for those platforms where relative + * links exist. */ if (tclPlatform != TCL_PLATFORM_WINDOWS && Tcl_FSGetPathType(link) == TCL_PATH_RELATIVE) { - - /* - * We need to follow this link which is - * relative to retVal's directory. This - * means concatenating the link onto - * the directory of the path so far. + /* + * We need to follow this link which is relative + * to retVal's directory. This means concatenating + * the link onto the directory of the path so far. */ CONST char *path = Tcl_GetStringFromObj(retVal, &curLen); + while (--curLen >= 0) { - if (IsSeparatorOrNull(path[curLen])) { - break; - } + if (IsSeparatorOrNull(path[curLen])) { + break; + } } if (Tcl_IsShared(retVal)) { TclDecrRefCount(retVal); retVal = Tcl_DuplicateObj(retVal); Tcl_IncrRefCount(retVal); } - /* We want the trailing slash */ + + /* + * We want the trailing slash. + */ + Tcl_SetObjLength(retVal, curLen+1); Tcl_AppendObjToObj(retVal, link); TclDecrRefCount(link); @@ -288,7 +290,11 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) TclDecrRefCount(retVal); retVal = link; linkStr = Tcl_GetStringFromObj(retVal, &curLen); - /* Convert to forward-slashes on windows */ + + /* + * Convert to forward-slashes on windows. + */ + if (tclPlatform == TCL_PLATFORM_WINDOWS) { int i; for (i = 0; i < curLen; i++) { @@ -303,7 +309,7 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) } /* - * Either way, we now remove the last path element + * Either way, we now remove the last path element. */ while (--curLen >= 0) { @@ -326,40 +332,42 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep); } } - - /* - * If we didn't make any changes, just use the input path + + /* + * If we didn't make any changes, just use the input path. */ if (retVal == NULL) { retVal = pathPtr; Tcl_IncrRefCount(retVal); - + if (Tcl_IsShared(retVal)) { - /* - * Unfortunately, the platform-specific normalization code - * which will be called below has no way of dealing with the - * case where an object is shared. It is expecting to - * modify an object in place. So, we must duplicate this - * here to ensure an object with a single ref-count. - * - * If that changes in the future (e.g. the normalize proc is - * given one object and is able to return a different one), - * then we could remove this code. + /* + * Unfortunately, the platform-specific normalization code which + * will be called below has no way of dealing with the case where + * an object is shared. It is expecting to modify an object in + * place. So, we must duplicate this here to ensure an object + * with a single ref-count. + * + * If that changes in the future (e.g. the normalize proc is given + * one object and is able to return a different one), then we + * could remove this code. */ + TclDecrRefCount(retVal); retVal = Tcl_DuplicateObj(pathPtr); Tcl_IncrRefCount(retVal); } } - /* - * Ensure a windows drive like C:/ has a trailing separator + /* + * Ensure a windows drive like C:/ has a trailing separator */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { int len; CONST char *path = Tcl_GetStringFromObj(retVal, &len); + if (len == 2 && path[0] != 0 && path[1] == ':') { if (Tcl_IsShared(retVal)) { TclDecrRefCount(retVal); @@ -370,31 +378,33 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) } } - /* - * Now we have an absolute path, with no '..', '.' sequences, - * but it still may not be in 'unique' form, depending on the - * platform. For instance, Unix is case-sensitive, so the - * path is ok. Windows is case-insensitive, and also has the - * weird 'longname/shortname' thing (e.g. C:/Program Files/ and - * C:/Progra~1/ are equivalent). - * - * Virtual file systems which may be registered may have - * other criteria for normalizing a path. + /* + * Now we have an absolute path, with no '..', '.' sequences, but it still + * may not be in 'unique' form, depending on the platform. For instance, + * Unix is case-sensitive, so the path is ok. Windows is case-insensitive, + * and also has the weird 'longname/shortname' thing (e.g. C:/Program + * Files/ and C:/Progra~1/ are equivalent). + * + * Virtual file systems which may be registered may have other criteria + * for normalizing a path. */ TclFSNormalizeToUniquePath(interp, retVal, 0, &clientData); - /* - * Since we know it is a normalized path, we can - * actually convert this object into an FsPath for - * greater efficiency + /* + * Since we know it is a normalized path, we can actually convert this + * object into an FsPath for greater efficiency */ TclFSMakePathFromNormalized(interp, retVal, clientData); if (clientDataPtr != NULL) { *clientDataPtr = clientData; } - /* This has a refCount of 1 for the caller */ + + /* + * This has a refCount of 1 for the caller, unlike many Tcl_Obj APIs. + */ + return retVal; } @@ -403,8 +413,8 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) * * Tcl_FSGetPathType -- * - * Determines whether a given path is relative to the current - * directory, relative to the current volume, or absolute. + * Determines whether a given path is relative to the current directory, + * relative to the current volume, or absolute. * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or @@ -428,18 +438,17 @@ Tcl_FSGetPathType(pathPtr) * * TclFSGetPathType -- * - * Determines whether a given path is relative to the current - * directory, relative to the current volume, or absolute. If the - * caller wishes to know which filesystem claimed the path (in the - * case for which the path is absolute), then a reference to a - * filesystem pointer can be passed in (but passing NULL is - * acceptable). + * Determines whether a given path is relative to the current directory, + * relative to the current volume, or absolute. If the caller wishes to + * know which filesystem claimed the path (in the case for which the path + * is absolute), then a reference to a filesystem pointer can be passed + * in (but passing NULL is acceptable). * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or - * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will - * be set if and only if it is non-NULL and the function's - * return value is TCL_PATH_ABSOLUTE. + * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and + * only if it is non-NULL and the function's return value is + * TCL_PATH_ABSOLUTE. * * Side effects: * None. @@ -454,18 +463,19 @@ TclFSGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr) int *driveNameLengthPtr; { if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) { - return TclGetPathType(pathPtr, filesystemPtrPtr, + return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, NULL); } else { FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr); + if (fsPathPtr->cwdPtr != NULL) { if (PATHFLAGS(pathPtr) == 0) { return TCL_PATH_RELATIVE; } - return TclFSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr, + return TclFSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr, driveNameLengthPtr); } else { - return TclGetPathType(pathPtr, filesystemPtrPtr, + return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, NULL); } } @@ -476,29 +486,28 @@ TclFSGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr) * * TclPathPart * - * This procedure calculates the requested part of the given - * path, which can be: - * + * This function calculates the requested part of the given path, which + * can be: + * * - the directory above ('file dirname') * - the tail ('file tail') * - the extension ('file extension') * - the root ('file root') - * - * The 'portion' parameter dictates which of these to calculate. - * There are a number of special cases both to be more efficient, - * and because the behaviour when given a path with only a single - * element is defined to require the expansion of that single - * element, where possible. - * - * Should look into integrating 'FileBasename' in tclFCmd.c into - * this function. - * + * + * The 'portion' parameter dictates which of these to calculate. There + * are a number of special cases both to be more efficient, and because + * the behaviour when given a path with only a single element is defined + * to require the expansion of that single element, where possible. + * + * Should look into integrating 'FileBasename' in tclFCmd.c into this + * function. + * * Results: - * NULL if an error occurred, otherwise a Tcl_Obj owned by - * the caller (i.e. most likely with refCount 1). + * NULL if an error occurred, otherwise a Tcl_Obj owned by the caller + * (i.e. most likely with refCount 1). * * Side effects: - * None. + * None. * *--------------------------------------------------------------------------- */ @@ -506,109 +515,106 @@ TclFSGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr) Tcl_Obj* TclPathPart(interp, pathPtr, portion) Tcl_Interp *interp; /* Used for error reporting */ - Tcl_Obj *pathPtr; /* Path to take dirname of */ - Tcl_PathPart portion; /* Requested portion of name */ + Tcl_Obj *pathPtr; /* Path to take dirname of */ + Tcl_PathPart portion; /* Requested portion of name */ { if (pathPtr->typePtr == &tclFsPathType) { FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr); - if (TclFSEpochOk(fsPathPtr->filesystemEpoch) + if (TclFSEpochOk(fsPathPtr->filesystemEpoch) && (PATHFLAGS(pathPtr) != 0)) { switch (portion) { - case TCL_PATH_DIRNAME: { - /* - * Check if the joined-on bit has any directory - * delimiters in it. If so, the 'dirname' would - * be a joining of the main part with the dirname - * of the joined-on bit. We could handle that - * special case here, but we don't, and instead - * just use the standardPath code. - */ - - CONST char *rest = TclGetString(fsPathPtr->normPathPtr); - if (strchr(rest, '/') != NULL) { - goto standardPath; - } - if (tclPlatform == TCL_PLATFORM_WINDOWS - && strchr(rest, '\\') != NULL) { - goto standardPath; - } + case TCL_PATH_DIRNAME: { + /* + * Check if the joined-on bit has any directory delimiters in + * it. If so, the 'dirname' would be a joining of the main + * part with the dirname of the joined-on bit. We could handle + * that special case here, but we don't, and instead just use + * the standardPath code. + */ - /* - * The joined-on path is simple, so we can just - * return here. - */ + CONST char *rest = TclGetString(fsPathPtr->normPathPtr); - Tcl_IncrRefCount(fsPathPtr->cwdPtr); - return fsPathPtr->cwdPtr; + if (strchr(rest, '/') != NULL) { + goto standardPath; + } + if (tclPlatform == TCL_PLATFORM_WINDOWS + && strchr(rest, '\\') != NULL) { + goto standardPath; } - case TCL_PATH_TAIL: { - /* - * Check if the joined-on bit has any directory - * delimiters in it. If so, the 'tail' would - * be only the part following the last delimiter. - * We could handle that special case here, but we - * don't, and instead just use the standardPath code. - */ - CONST char *rest = TclGetString(fsPathPtr->normPathPtr); - if (strchr(rest, '/') != NULL) { - goto standardPath; - } - if (tclPlatform == TCL_PLATFORM_WINDOWS - && strchr(rest, '\\') != NULL) { - goto standardPath; - } - Tcl_IncrRefCount(fsPathPtr->normPathPtr); - return fsPathPtr->normPathPtr; + /* + * The joined-on path is simple, so we can just return here. + */ + + Tcl_IncrRefCount(fsPathPtr->cwdPtr); + return fsPathPtr->cwdPtr; + } + case TCL_PATH_TAIL: { + /* + * Check if the joined-on bit has any directory delimiters in + * it. If so, the 'tail' would be only the part following the + * last delimiter. We could handle that special case here, but + * we don't, and instead just use the standardPath code. + */ + + CONST char *rest = TclGetString(fsPathPtr->normPathPtr); + + if (strchr(rest, '/') != NULL) { + goto standardPath; } - case TCL_PATH_EXTENSION: { - return GetExtension(fsPathPtr->normPathPtr); + if (tclPlatform == TCL_PLATFORM_WINDOWS + && strchr(rest, '\\') != NULL) { + goto standardPath; } - case TCL_PATH_ROOT: { - /* Unimplemented */ - CONST char *fileName, *extension; - int length; - fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, - &length); - extension = TclGetExtension(fileName); - if (extension == NULL) { - /* - * There is no extension so the root is the - * same as the path we were given. - */ - Tcl_IncrRefCount(pathPtr); - return pathPtr; - } else { - /* - * Duplicate the object we were given and - * then trim off the extension of the - * tail component of the path. - */ + Tcl_IncrRefCount(fsPathPtr->normPathPtr); + return fsPathPtr->normPathPtr; + } + case TCL_PATH_EXTENSION: + return GetExtension(fsPathPtr->normPathPtr); + case TCL_PATH_ROOT: { + /* Unimplemented */ + CONST char *fileName, *extension; + int length; + + fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, + &length); + extension = TclGetExtension(fileName); + if (extension == NULL) { + /* + * There is no extension so the root is the same as the + * path we were given. + */ - FsPath *fsDupPtr; - Tcl_Obj *root = Tcl_DuplicateObj(pathPtr); - - Tcl_IncrRefCount(root); - fsDupPtr = (FsPath*) PATHOBJ(root); - if (Tcl_IsShared(fsDupPtr->normPathPtr)) { - TclDecrRefCount(fsDupPtr->normPathPtr); - fsDupPtr->normPathPtr = - Tcl_NewStringObj(fileName, - (int)(length - strlen(extension))); - Tcl_IncrRefCount(fsDupPtr->normPathPtr); - } else { - Tcl_SetObjLength(fsDupPtr->normPathPtr, - (int)(length - strlen(extension))); - } - return root; + Tcl_IncrRefCount(pathPtr); + return pathPtr; + } else { + /* + * Duplicate the object we were given and then trim off + * the extension of the tail component of the path. + */ + + FsPath *fsDupPtr; + Tcl_Obj *root = Tcl_DuplicateObj(pathPtr); + + Tcl_IncrRefCount(root); + fsDupPtr = (FsPath*) PATHOBJ(root); + if (Tcl_IsShared(fsDupPtr->normPathPtr)) { + TclDecrRefCount(fsDupPtr->normPathPtr); + fsDupPtr->normPathPtr = Tcl_NewStringObj(fileName, + (int)(length - strlen(extension))); + Tcl_IncrRefCount(fsDupPtr->normPathPtr); + } else { + Tcl_SetObjLength(fsDupPtr->normPathPtr, + (int)(length - strlen(extension))); } + return root; } - default: { - /* We should never get here */ - Tcl_Panic("Bad portion to TclPathPart"); - /* For less clever compilers */ - return NULL; - } + } + default: + /* We should never get here */ + Tcl_Panic("Bad portion to TclPathPart"); + /* For less clever compilers */ + return NULL; } } else if (fsPathPtr->cwdPtr != NULL) { /* Relative path */ @@ -621,35 +627,34 @@ TclPathPart(interp, pathPtr, portion) int splitElements; Tcl_Obj *splitPtr; Tcl_Obj *resultPtr; - standardPath: - resultPtr = NULL; - if (portion == TCL_PATH_EXTENSION) { + standardPath: + resultPtr = NULL; + if (portion == TCL_PATH_EXTENSION) { return GetExtension(pathPtr); - } else if (portion == TCL_PATH_ROOT) { + } else if (portion == TCL_PATH_ROOT) { int length; CONST char *fileName, *extension; - + fileName = Tcl_GetStringFromObj(pathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { Tcl_IncrRefCount(pathPtr); return pathPtr; } else { - Tcl_Obj *root = Tcl_NewStringObj(fileName, + Tcl_Obj *root = Tcl_NewStringObj(fileName, (int) (length - strlen(extension))); Tcl_IncrRefCount(root); return root; } - } - - /* - * The behaviour we want here is slightly different to - * the standard Tcl_FSSplitPath in the handling of home - * directories; Tcl_FSSplitPath preserves the "~" while - * this code computes the actual full path name, if we - * had just a single component. - */ + } + + /* + * The behaviour we want here is slightly different to the standard + * Tcl_FSSplitPath in the handling of home directories; + * Tcl_FSSplitPath preserves the "~" while this code computes the + * actual full path name, if we had just a single component. + */ splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); Tcl_IncrRefCount(splitPtr); @@ -666,8 +671,8 @@ TclPathPart(interp, pathPtr, portion) } if (portion == TCL_PATH_TAIL) { /* - * Return the last component, unless it is the only component, - * and it is the root of an absolute path. + * Return the last component, unless it is the only component, and + * it is the root of an absolute path. */ if ((splitElements > 0) && ((splitElements > 1) || @@ -678,14 +683,14 @@ TclPathPart(interp, pathPtr, portion) } } else { /* - * Return all but the last component. If there is only one + * Return all but the last component. If there is only one * component, return it if the path was non-relative, otherwise * return the current directory. */ if (splitElements > 1) { resultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1); - } else if (splitElements == 0 || + } else if (splitElements == 0 || (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) { resultPtr = Tcl_NewStringObj(".", 1); } else { @@ -699,16 +704,16 @@ TclPathPart(interp, pathPtr, portion) } /* - * Simple helper function + * Simple helper function */ static Tcl_Obj* -GetExtension(pathPtr) +GetExtension(pathPtr) Tcl_Obj *pathPtr; { CONST char *tail, *extension; Tcl_Obj *ret; - + tail = TclGetString(pathPtr); extension = TclGetExtension(tail); if (extension == NULL) { @@ -725,29 +730,28 @@ GetExtension(pathPtr) * * Tcl_FSJoinPath -- * - * This function takes the given Tcl_Obj, which should be a valid - * list, and returns the path object given by considering the - * first 'elements' elements as valid path segments (each path - * segment may be a complete path, a partial path or just a single - * possible directory or file name). If any path segment is - * actually an absolute path, then all prior path segments are - * discarded. - * - * If elements < 0, we use the entire list that was given. - * - * It is possible that the returned object is actually an element - * of the given list, so the caller should be careful to store a - * refCount to it before freeing the list. - * + * This function takes the given Tcl_Obj, which should be a valid list, + * and returns the path object given by considering the first 'elements' + * elements as valid path segments (each path segment may be a complete + * path, a partial path or just a single possible directory or file + * name). If any path segment is actually an absolute path, then all + * prior path segments are discarded. + * + * If elements < 0, we use the entire list that was given. + * + * It is possible that the returned object is actually an element of the + * given list, so the caller should be careful to store a refCount to it + * before freeing the list. + * * Results: - * Returns object with refCount of zero, (or if non-zero, it has - * references elsewhere in Tcl). Either way, the caller must - * increment its refCount before use. Note that in the case where - * the caller has asked to join zero elements of the list, the - * return value will be an empty-string Tcl_Obj. - * - * If the given listObj was invalid, then the calling routine has - * a bug, and this function will just return NULL. + * Returns object with refCount of zero, (or if non-zero, it has + * references elsewhere in Tcl). Either way, the caller must increment + * its refCount before use. Note that in the case where the caller has + * asked to join zero elements of the list, the return value will be an + * empty-string Tcl_Obj. + * + * If the given listObj was invalid, then the calling routine has a bug, + * and this function will just return NULL. * * Side effects: * None. @@ -755,36 +759,43 @@ GetExtension(pathPtr) *--------------------------------------------------------------------------- */ -Tcl_Obj* +Tcl_Obj* Tcl_FSJoinPath(listObj, elements) - Tcl_Obj *listObj; /* Path elements to join, may have refCount 0 */ - int elements; /* Number of elements to use (-1 = all) */ + Tcl_Obj *listObj; /* Path elements to join, may have a zero + * reference count. */ + int elements; /* Number of elements to use (-1 = all) */ { Tcl_Obj *res; int i; Tcl_Filesystem *fsPtr = NULL; - + if (elements < 0) { if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) { return NULL; } } else { - /* Just make sure it is a valid list */ + /* + * Just make sure it is a valid list. + */ + int listTest; + if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) { return NULL; } - /* - * Correct this if it is too large, otherwise we will - * waste our time joining null elements to the path + + /* + * Correct this if it is too large, otherwise we will waste our time + * joining null elements to the path. */ + if (elements > listTest) { elements = listTest; } } - + res = NULL; - + for (i = 0; i < elements; i++) { Tcl_Obj *elt; int driveNameLength; @@ -794,23 +805,23 @@ Tcl_FSJoinPath(listObj, elements) int length; char *ptr; Tcl_Obj *driveName = NULL; - + Tcl_ListObjIndex(NULL, listObj, i, &elt); - - /* - * This is a special case where we can be much more - * efficient, where we are joining a single relative path - * onto an object that is already of path type. The - * 'TclNewFSPathObj' call below creates an object which - * can be normalized more efficiently. Currently we only - * use the special case when we have exactly two elements, - * but we could expand that in the future. + + /* + * This is a special case where we can be much more efficient, where + * we are joining a single relative path onto an object that is + * already of path type. The 'TclNewFSPathObj' call below creates an + * object which can be normalized more efficiently. Currently we only + * use the special case when we have exactly two elements, but we + * could expand that in the future. */ if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType) && !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) { Tcl_Obj *tail; Tcl_PathType type; + Tcl_ListObjIndex(NULL, listObj, i+1, &tail); type = TclGetPathType(tail, NULL, NULL, NULL); if (type == TCL_PATH_RELATIVE) { @@ -819,36 +830,37 @@ Tcl_FSJoinPath(listObj, elements) str = Tcl_GetStringFromObj(tail, &len); if (len == 0) { - /* - * This happens if we try to handle the root volume - * '/'. There's no need to return a special path - * object, when the base itself is just fine! + /* + * This happens if we try to handle the root volume '/'. + * There's no need to return a special path object, when + * the base itself is just fine! */ + if (res != NULL) { TclDecrRefCount(res); } return elt; } - /* - * If it doesn't begin with '.' and is a unix - * path or it a windows path without backslashes, then we - * can be very efficient here. (In fact even a windows - * path with backslashes can be joined efficiently, but - * the path object would not have forward slashes only, - * and this would therefore contradict our 'file join' - * documentation). + /* + * If it doesn't begin with '.' and is a unix path or it a + * windows path without backslashes, then we can be very + * efficient here. (In fact even a windows path with + * backslashes can be joined efficiently, but the path object + * would not have forward slashes only, and this would + * therefore contradict our 'file join' documentation). */ - if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS) + if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS) || (strchr(str, '\\') == NULL))) { - /* - * Finally, on Windows, 'file join' is defined to - * convert all backslashes to forward slashes, - * so the base part cannot have backslashes either. + /* + * Finally, on Windows, 'file join' is defined to convert + * all backslashes to forward slashes, so the base part + * cannot have backslashes either. */ + if ((tclPlatform != TCL_PLATFORM_WINDOWS) - || (strchr(Tcl_GetString(elt), '\\') == NULL)) { + || (strchr(Tcl_GetString(elt), '\\') == NULL)) { if (res != NULL) { TclDecrRefCount(res); } @@ -856,28 +868,26 @@ Tcl_FSJoinPath(listObj, elements) } } - /* - * Otherwise we don't have an easy join, and - * we must let the more general code below handle - * things + /* + * Otherwise we don't have an easy join, and we must let the + * more general code below handle things */ + } else if (tclPlatform == TCL_PLATFORM_UNIX) { + if (res != NULL) { + TclDecrRefCount(res); + } + return tail; } else { - if (tclPlatform == TCL_PLATFORM_UNIX) { - if (res != NULL) { - TclDecrRefCount(res); - } - return tail; - } else { - CONST char *str; - int len; - str = Tcl_GetStringFromObj(tail, &len); - if (tclPlatform == TCL_PLATFORM_WINDOWS) { - if (strchr(str, '\\') == NULL) { - if (res != NULL) { - TclDecrRefCount(res); - } - return tail; + CONST char *str; + int len; + + str = Tcl_GetStringFromObj(tail, &len); + if (tclPlatform == TCL_PLATFORM_WINDOWS) { + if (strchr(str, '\\') == NULL) { + if (res != NULL) { + TclDecrRefCount(res); } + return tail; } } } @@ -885,92 +895,96 @@ Tcl_FSJoinPath(listObj, elements) strElt = Tcl_GetStringFromObj(elt, &strEltLen); type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName); if (type != TCL_PATH_RELATIVE) { - /* Zero out the current result */ + /* + * Zero out the current result. + */ + if (res != NULL) { TclDecrRefCount(res); } if (driveName != NULL) { /* - * We've been given a separate drive-name object, - * because the prefix in 'elt' is not in a suitable - * format for us (e.g. it may contain irrelevant - * multiple separators, like C://///foo). + * We've been given a separate drive-name object, because the + * prefix in 'elt' is not in a suitable format for us (e.g. it + * may contain irrelevant multiple separators, like + * C://///foo). */ res = Tcl_DuplicateObj(driveName); TclDecrRefCount(driveName); - /* - * Do not set driveName to NULL, because we will check - * its value below (but we won't access the contents, - * since those have been cleaned-up). + /* + * Do not set driveName to NULL, because we will check its + * value below (but we won't access the contents, since those + * have been cleaned-up). */ } else { res = Tcl_NewStringObj(strElt, driveNameLength); } strElt += driveNameLength; } - - /* - * Optimisation block: if this is the last element to be - * examined, and it is absolute or the only element, and the - * drive-prefix was ok (if there is one), it might be that the - * path is already in a suitable form to be returned. Then we - * can short-cut the rest of this procedure. + + /* + * Optimisation block: if this is the last element to be examined, and + * it is absolute or the only element, and the drive-prefix was ok (if + * there is one), it might be that the path is already in a suitable + * form to be returned. Then we can short-cut the rest of this + * function. */ - if ((driveName == NULL) && (i == (elements - 1)) + if ((driveName == NULL) && (i == (elements - 1)) && (type != TCL_PATH_RELATIVE || res == NULL)) { - /* - * It's the last path segment. Perform a quick check if - * the path is already in a suitable form. + /* + * It's the last path segment. Perform a quick check if the path + * is already in a suitable form. */ - + if (tclPlatform == TCL_PLATFORM_WINDOWS) { if (strchr(strElt, '\\') != NULL) { goto noQuickReturn; } } - ptr = strElt; - while (*ptr != '\0') { - if (*ptr == '/' && (ptr[1] == '/' || ptr[1] == '\0')) { - /* - * We have a repeated file separator, which - * means the path is not in normalized form - */ - goto noQuickReturn; - } - ptr++; - } - if (res != NULL) { + ptr = strElt; + while (*ptr != '\0') { + if (*ptr == '/' && (ptr[1] == '/' || ptr[1] == '\0')) { + /* + * We have a repeated file separator, which means the path + * is not in normalized form + */ + goto noQuickReturn; + } + ptr++; + } + if (res != NULL) { TclDecrRefCount(res); } - /* - * This element is just what we want to return already - - * no further manipulation is requred. - */ - return elt; + + /* + * This element is just what we want to return already - no + * further manipulation is requred. + */ + + return elt; } - /* - * The path element was not of a suitable form to be - * returned as is. We need to perform a more complex - * operation here. - */ + /* + * The path element was not of a suitable form to be returned as is. + * We need to perform a more complex operation here. + */ + + noQuickReturn: - noQuickReturn: - if (res == NULL) { res = Tcl_NewObj(); ptr = Tcl_GetStringFromObj(res, &length); } else { ptr = Tcl_GetStringFromObj(res, &length); } - - /* - * Strip off any './' before a tilde, unless this is the - * beginning of the path. + + /* + * Strip off any './' before a tilde, unless this is the beginning of + * the path. */ if (length > 0 && strEltLen > 0 && (strElt[0] == '.') && @@ -978,23 +992,22 @@ Tcl_FSJoinPath(listObj, elements) strElt += 2; } - /* - * A NULL value for fsPtr at this stage basically means - * we're trying to join a relative path onto something - * which is also relative (or empty). There's nothing - * particularly wrong with that. + /* + * A NULL value for fsPtr at this stage basically means we're trying + * to join a relative path onto something which is also relative (or + * empty). There's nothing particularly wrong with that. */ if (*strElt == '\0') { continue; } - + if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) { TclpNativeJoinPath(res, strElt); } else { char separator = '/'; int needsSep = 0; - + if (fsPtr->filesystemSeparatorProc != NULL) { Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res); if (sep != NULL) { @@ -1029,7 +1042,7 @@ Tcl_FSJoinPath(listObj, elements) } } if (res == NULL) { - res = Tcl_NewObj(); + res = Tcl_NewObj(); } return res; } @@ -1039,17 +1052,15 @@ Tcl_FSJoinPath(listObj, elements) * * Tcl_FSConvertToPathType -- * - * This function tries to convert the given Tcl_Obj to a valid - * Tcl path type, taking account of the fact that the cwd may - * have changed even if this object is already supposedly of - * the correct type. - * - * The filename may begin with "~" (to indicate current user's - * home directory) or "~<user>" (to indicate any user's home - * directory). + * This function tries to convert the given Tcl_Obj to a valid Tcl path + * type, taking account of the fact that the cwd may have changed even if + * this object is already supposedly of the correct type. + * + * The filename may begin with "~" (to indicate current user's home + * directory) or "~<user>" (to indicate any user's home directory). * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * The old representation may be freed, and new memory allocated. @@ -1057,21 +1068,21 @@ Tcl_FSJoinPath(listObj, elements) *--------------------------------------------------------------------------- */ -int +int Tcl_FSConvertToPathType(interp, pathPtr) - Tcl_Interp *interp; /* Interpreter in which to store error - * message (if necessary). */ - Tcl_Obj *pathPtr; /* Object to convert to a valid, current - * path type. */ + Tcl_Interp *interp; /* Interpreter in which to store error message + * (if necessary). */ + Tcl_Obj *pathPtr; /* Object to convert to a valid, current path + * type. */ { - /* - * While it is bad practice to examine an object's type directly, - * this is actually the best thing to do here. The reason is that - * if we are converting this object to FsPath type for the first - * time, we don't need to worry whether the 'cwd' has changed. - * On the other hand, if this object is already of FsPath type, - * and is a relative path, we do have to worry about the cwd. - * If the cwd has changed, we must recompute the path. + /* + * While it is bad practice to examine an object's type directly, this is + * actually the best thing to do here. The reason is that if we are + * converting this object to FsPath type for the first time, we don't need + * to worry whether the 'cwd' has changed. On the other hand, if this + * object is already of FsPath type, and is a relative path, we do have to + * worry about the cwd. If the cwd has changed, we must recompute the + * path. */ if (pathPtr->typePtr == &tclFsPathType) { @@ -1085,9 +1096,9 @@ Tcl_FSConvertToPathType(interp, pathPtr) return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); } return TCL_OK; - /* + /* * We used to have more complex code here: - * + * * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) { * return TCL_OK; * } else { @@ -1102,7 +1113,7 @@ Tcl_FSConvertToPathType(interp, pathPtr) * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); * } * } - * + * * But we no longer believe this is necessary. */ } else { @@ -1110,7 +1121,7 @@ Tcl_FSConvertToPathType(interp, pathPtr) } } -/* +/* * Helper function for normalization. */ @@ -1119,23 +1130,21 @@ IsSeparatorOrNull(ch) int ch; { if (ch == 0) { - return 1; + return 1; } switch (tclPlatform) { - case TCL_PLATFORM_UNIX: { - return (ch == '/' ? 1 : 0); - } - case TCL_PLATFORM_WINDOWS: { - return ((ch == '/' || ch == '\\') ? 1 : 0); - } + case TCL_PLATFORM_UNIX: + return (ch == '/' ? 1 : 0); + case TCL_PLATFORM_WINDOWS: + return ((ch == '/' || ch == '\\') ? 1 : 0); } return 0; } -/* - * Helper function for SetFsPathFromAny. Returns position of first - * directory delimiter in the path. If no separator is found, then - * returns the position of the end of the string. +/* + * Helper function for SetFsPathFromAny. Returns position of first directory + * delimiter in the path. If no separator is found, then returns the position + * of the end of the string. */ static int @@ -1171,17 +1180,16 @@ FindSplitPos(path, separator) * * TclNewFSPathObj -- * - * Creates a path object whose string representation is '[file join - * dirPtr addStrRep]', but does so in a way that allows for more - * efficient creation and caching of normalized paths, and more - * efficient 'file dirname', 'file tail', etc. - * + * Creates a path object whose string representation is '[file join + * dirPtr addStrRep]', but does so in a way that allows for more + * efficient creation and caching of normalized paths, and more efficient + * 'file dirname', 'file tail', etc. + * * Assumptions: - * 'dirPtr' must be an absolute path. - * 'len' may not be zero. - * + * 'dirPtr' must be an absolute path. 'len' may not be zero. + * * Results: - * The new Tcl object, with refCount zero. + * The new Tcl object, with refCount zero. * * Side effects: * Memory is allocated. 'dirPtr' gets an additional refCount. @@ -1195,13 +1203,16 @@ TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len) FsPath *fsPathPtr; Tcl_Obj *pathPtr; ThreadSpecificData *tsdPtr; - + tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - + pathPtr = Tcl_NewObj(); fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); - - /* Setup the path */ + + /* + * Set up the path. + */ + fsPathPtr->translatedPathPtr = NULL; fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len); Tcl_IncrRefCount(fsPathPtr->normPathPtr); @@ -1225,23 +1236,22 @@ TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len) * * TclFSMakePathRelative -- * - * Only for internal use. - * - * Takes a path and a directory, where we _assume_ both path and - * directory are absolute, normalized and that the path lies - * inside the directory. Returns a Tcl_Obj representing filename - * of the path relative to the directory. - * - * In the case where the resulting path would start with a '~', we - * take special care to return an ordinary string. This means to - * use that path (and not have it interpreted as a user name), - * one must prepend './'. This may seem strange, but that is how - * 'glob' is currently defined. - * + * Only for internal use. + * + * Takes a path and a directory, where we _assume_ both path and + * directory are absolute, normalized and that the path lies inside the + * directory. Returns a Tcl_Obj representing filename of the path + * relative to the directory. + * + * In the case where the resulting path would start with a '~', we take + * special care to return an ordinary string. This means to use that + * path (and not have it interpreted as a user name), one must prepend + * './'. This may seem strange, but that is how 'glob' is currently + * defined. + * * Results: - * NULL on error, otherwise a valid object, typically with - * refCount of zero, which it is assumed the caller will - * increment. + * NULL on error, otherwise a valid object, typically with refCount of + * zero, which it is assumed the caller will increment. * * Side effects: * The old representation may be freed, and new memory allocated. @@ -1258,13 +1268,17 @@ TclFSMakePathRelative(interp, pathPtr, cwdPtr) int cwdLen, len; CONST char *tempStr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - + if (pathPtr->typePtr == &tclFsPathType) { FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr); - if (PATHFLAGS(pathPtr) != 0 + if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) { pathPtr = fsPathPtr->normPathPtr; - /* Free old representation */ + + /* + * Free old representation. + */ + if (pathPtr->typePtr != NULL) { if (pathPtr->bytes == NULL) { if (pathPtr->typePtr->updateStringProc == NULL) { @@ -1279,20 +1293,26 @@ TclFSMakePathRelative(interp, pathPtr, cwdPtr) } TclFreeIntRep(pathPtr); } - /* Now pathPtr is a string object */ - + + /* + * Now pathPtr is a string object. + */ + if (Tcl_GetString(pathPtr)[0] == '~') { - /* - * If the first character of the path is a tilde, - * we must just return the path as is, to agree - * with the defined behaviour of 'glob'. + /* + * If the first character of the path is a tilde, we must just + * return the path as is, to agree with the defined behaviour + * of 'glob'. */ return pathPtr; } fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); - /* Circular reference, by design */ + /* + * Circular reference, by design. + */ + fsPathPtr->translatedPathPtr = pathPtr; fsPathPtr->normPathPtr = NULL; fsPathPtr->cwdPtr = cwdPtr; @@ -1309,38 +1329,36 @@ TclFSMakePathRelative(interp, pathPtr, cwdPtr) } } - /* + /* * We know the cwd is a normalised object which does not end in a - * directory delimiter, unless the cwd is the name of a volume, in - * which case it will end in a delimiter! We handle this - * situation here. A better test than the '!= sep' might be to - * simply check if 'cwd' is a root volume. - * - * Note that if we get this wrong, we will strip off either too - * much or too little below, leading to wrong answers returned by - * glob. + * directory delimiter, unless the cwd is the name of a volume, in which + * case it will end in a delimiter! We handle this situation here. A + * better test than the '!= sep' might be to simply check if 'cwd' is a + * root volume. + * + * Note that if we get this wrong, we will strip off either too much or + * too little below, leading to wrong answers returned by glob. */ tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); - /* - * Should we perhaps use 'Tcl_FSPathSeparator'? But then what - * about the Windows special case? Perhaps we should just check - * if cwd is a root volume. + /* + * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the + * Windows special case? Perhaps we should just check if cwd is a root + * volume. */ switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - if (tempStr[cwdLen-1] != '/') { - cwdLen++; - } - break; - case TCL_PLATFORM_WINDOWS: - if (tempStr[cwdLen-1] != '/' - && tempStr[cwdLen-1] != '\\') { - cwdLen++; - } - break; + case TCL_PLATFORM_UNIX: + if (tempStr[cwdLen-1] != '/') { + cwdLen++; + } + break; + case TCL_PLATFORM_WINDOWS: + if (tempStr[cwdLen-1] != '/' && tempStr[cwdLen-1] != '\\') { + cwdLen++; + } + break; } tempStr = Tcl_GetStringFromObj(pathPtr, &len); @@ -1352,11 +1370,11 @@ TclFSMakePathRelative(interp, pathPtr, cwdPtr) * * TclFSMakePathFromNormalized -- * - * Like SetFsPathFromAny, but assumes the given object is an - * absolute normalized path. Only for internal use. - * + * Like SetFsPathFromAny, but assumes the given object is an absolute + * normalized path. Only for internal use. + * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * The old representation may be freed, and new memory allocated. @@ -1377,15 +1395,18 @@ TclFSMakePathFromNormalized(interp, pathPtr, nativeRep) if (pathPtr->typePtr == &tclFsPathType) { return TCL_OK; } - - /* Free old representation */ + + /* + * Free old representation + */ + if (pathPtr->typePtr != NULL) { if (pathPtr->bytes == NULL) { if (pathPtr->typePtr->updateStringProc == NULL) { if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't find object", - "string representation", (char *) NULL); + "string representation", (char *) NULL); } return TCL_ERROR; } @@ -1395,9 +1416,17 @@ TclFSMakePathFromNormalized(interp, pathPtr, nativeRep) } fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); - /* It's a pure normalized absolute path */ + + /* + * It's a pure normalized absolute path. + */ + fsPathPtr->translatedPathPtr = NULL; - /* Circular reference by design */ + + /* + * Circular reference by design. + */ + fsPathPtr->normPathPtr = pathPtr; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = nativeRep; @@ -1416,20 +1445,19 @@ TclFSMakePathFromNormalized(interp, pathPtr, nativeRep) * * Tcl_FSNewNativePath -- * - * This function performs the something like the reverse of the - * usual obj->path->nativerep conversions. If some code retrieves - * a path in native form (from, e.g. readlink or a native dialog), - * and that path is to be used at the Tcl level, then calling - * this function is an efficient way of creating the appropriate - * path object type. - * - * Any memory which is allocated for 'clientData' should be retained - * until clientData is passed to the filesystem's freeInternalRepProc - * when it can be freed. The built in platform-specific filesystems - * use 'ckalloc' to allocate clientData, and ckfree to free it. + * This function performs the something like the reverse of the usual + * obj->path->nativerep conversions. If some code retrieves a path in + * native form (from, e.g. readlink or a native dialog), and that path is + * to be used at the Tcl level, then calling this function is an + * efficient way of creating the appropriate path object type. + * + * Any memory which is allocated for 'clientData' should be retained + * until clientData is passed to the filesystem's freeInternalRepProc + * when it can be freed. The built in platform-specific filesystems use + * 'ckalloc' to allocate clientData, and ckfree to free it. * * Results: - * NULL or a valid path object pointer, with refCount zero. + * NULL or a valid path object pointer, with refCount zero. * * Side effects: * New memory may be allocated. @@ -1447,17 +1475,18 @@ Tcl_FSNewNativePath(fromFilesystem, clientData) FilesystemRecord *fsFromPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - + pathPtr = TclFSInternalToNormalized(fromFilesystem, clientData, - &fsFromPtr); + &fsFromPtr); if (pathPtr == NULL) { return NULL; } - - /* - * Free old representation; shouldn't normally be any, - * but best to be safe. + + /* + * Free old representation; shouldn't normally be any, but best to be + * safe. */ + if (pathPtr->typePtr != NULL) { if (pathPtr->bytes == NULL) { if (pathPtr->typePtr->updateStringProc == NULL) { @@ -1467,17 +1496,21 @@ Tcl_FSNewNativePath(fromFilesystem, clientData) } TclFreeIntRep(pathPtr); } - - fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); + + fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = NULL; - /* Circular reference, by design */ + + /* + * Circular reference, by design. + */ + fsPathPtr->normPathPtr = pathPtr; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = clientData; fsPathPtr->fsRecPtr = fsFromPtr; fsPathPtr->fsRecPtr->fileRefCount++; - fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; + fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; PATHOBJ(pathPtr) = (VOID *) fsPathPtr; PATHFLAGS(pathPtr) = 0; @@ -1491,14 +1524,13 @@ Tcl_FSNewNativePath(fromFilesystem, clientData) * * Tcl_FSGetTranslatedPath -- * - * This function attempts to extract the translated path - * from the given Tcl_Obj. If the translation succeeds (i.e. the - * object is a valid path), then it is returned. Otherwise NULL - * will be returned, and an error message may be left in the - * interpreter (if it is non-NULL) + * This function attempts to extract the translated path from the given + * Tcl_Obj. If the translation succeeds (i.e. the object is a valid + * path), then it is returned. Otherwise NULL will be returned, and an + * error message may be left in the interpreter (if it is non-NULL) * * Results: - * NULL or a valid Tcl_Obj pointer. + * NULL or a valid Tcl_Obj pointer. * * Side effects: * Only those of 'Tcl_FSConvertToPathType' @@ -1506,7 +1538,7 @@ Tcl_FSNewNativePath(fromFilesystem, clientData) *--------------------------------------------------------------------------- */ -Tcl_Obj* +Tcl_Obj* Tcl_FSGetTranslatedPath(interp, pathPtr) Tcl_Interp *interp; Tcl_Obj* pathPtr; @@ -1522,16 +1554,19 @@ Tcl_FSGetTranslatedPath(interp, pathPtr) if (PATHFLAGS(pathPtr) != 0) { retObj = Tcl_FSGetNormalizedPath(interp, pathPtr); } else { - /* - * It is a pure absolute, normalized path object. - * This is something like being a 'pure list'. The - * object's string, translatedPath and normalizedPath - * are all identical. + /* + * It is a pure absolute, normalized path object. This is + * something like being a 'pure list'. The object's string, + * translatedPath and normalizedPath are all identical. */ + retObj = srcFsPathPtr->normPathPtr; } } else { - /* It is an ordinary path object */ + /* + * It is an ordinary path object. + */ + retObj = srcFsPathPtr->translatedPathPtr; } @@ -1544,14 +1579,13 @@ Tcl_FSGetTranslatedPath(interp, pathPtr) * * Tcl_FSGetTranslatedStringPath -- * - * This function attempts to extract the translated path - * from the given Tcl_Obj. If the translation succeeds (i.e. the - * object is a valid path), then the path is returned. Otherwise NULL - * will be returned, and an error message may be left in the - * interpreter (if it is non-NULL) + * This function attempts to extract the translated path from the given + * Tcl_Obj. If the translation succeeds (i.e. the object is a valid + * path), then the path is returned. Otherwise NULL will be returned, and + * an error message may be left in the interpreter (if it is non-NULL) * * Results: - * NULL or a valid string. + * NULL or a valid string. * * Side effects: * Only those of 'Tcl_FSConvertToPathType' @@ -1569,6 +1603,7 @@ Tcl_FSGetTranslatedStringPath(interp, pathPtr) if (transPtr != NULL) { int len; CONST char *result, *orig; + orig = Tcl_GetStringFromObj(transPtr, &len); result = (char*) ckalloc((unsigned)(len+1)); memcpy((VOID*) result, (VOID*) orig, (size_t) (len+1)); @@ -1584,21 +1619,21 @@ Tcl_FSGetTranslatedStringPath(interp, pathPtr) * * Tcl_FSGetNormalizedPath -- * - * This important function attempts to extract from the given Tcl_Obj - * a unique normalised path representation, whose string value can - * be used as a unique identifier for the file. + * This important function attempts to extract from the given Tcl_Obj a + * unique normalised path representation, whose string value can be used + * as a unique identifier for the file. * * Results: - * NULL or a valid path object pointer. + * NULL or a valid path object pointer. * * Side effects: - * New memory may be allocated. The Tcl 'errno' may be modified - * in the process of trying to examine various path possibilities. + * New memory may be allocated. The Tcl 'errno' may be modified in the + * process of trying to examine various path possibilities. * *--------------------------------------------------------------------------- */ -Tcl_Obj* +Tcl_Obj* Tcl_FSGetNormalizedPath(interp, pathPtr) Tcl_Interp *interp; Tcl_Obj* pathPtr; @@ -1611,9 +1646,9 @@ Tcl_FSGetNormalizedPath(interp, pathPtr) fsPathPtr = (FsPath*) PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0) { - /* - * This is a special path object which is the result of - * something like 'file join' + /* + * This is a special path object which is the result of something like + * 'file join' */ Tcl_Obj *dir, *copy; @@ -1621,7 +1656,7 @@ Tcl_FSGetNormalizedPath(interp, pathPtr) int pathType; CONST char *cwdStr; ClientData clientData = NULL; - + pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); if (dir == NULL) { @@ -1637,60 +1672,61 @@ Tcl_FSGetNormalizedPath(interp, pathPtr) /* * We now own a reference on both 'dir' and 'copy' */ - + cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); - /* - * Should we perhaps use 'Tcl_FSPathSeparator'? - * But then what about the Windows special case? - * Perhaps we should just check if cwd is a root volume. - * We should never get cwdLen == 0 in this code path. + /* + * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about + * the Windows special case? Perhaps we should just check if cwd is a + * root volume. We should never get cwdLen == 0 in this code path. */ switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - if (cwdStr[cwdLen-1] != '/') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - break; - case TCL_PLATFORM_WINDOWS: - if (cwdStr[cwdLen-1] != '/' - && cwdStr[cwdLen-1] != '\\') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - break; + case TCL_PLATFORM_UNIX: + if (cwdStr[cwdLen-1] != '/') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + break; + case TCL_PLATFORM_WINDOWS: + if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + break; } Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); - /* - * Normalize the combined string, but only starting after - * the end of the previously normalized 'dir'. This should - * be much faster! We use 'cwdLen-1' so that we are - * already pointing at the dir-separator that we know about. - * The normalization code will actually start off directly - * after that separator. + /* + * Normalize the combined string, but only starting after the end of + * the previously normalized 'dir'. This should be much faster! We + * use 'cwdLen-1' so that we are already pointing at the dir-separator + * that we know about. The normalization code will actually start off + * directly after that separator. */ - TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, + TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); /* * Now we need to construct the new path object */ - + if (pathType == TCL_PATH_RELATIVE) { FsPath* origDirFsPathPtr; Tcl_Obj *origDir = fsPathPtr->cwdPtr; origDirFsPathPtr = (FsPath*) PATHOBJ(origDir); - + fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr; Tcl_IncrRefCount(fsPathPtr->cwdPtr); - + TclDecrRefCount(fsPathPtr->normPathPtr); fsPathPtr->normPathPtr = copy; - /* That's our reference to copy used */ + + /* + * That's our reference to copy used. + */ + TclDecrRefCount(dir); TclDecrRefCount(origDir); } else { @@ -1698,7 +1734,11 @@ Tcl_FSGetNormalizedPath(interp, pathPtr) fsPathPtr->cwdPtr = NULL; TclDecrRefCount(fsPathPtr->normPathPtr); fsPathPtr->normPathPtr = copy; - /* That's our reference to copy used */ + + /* + * That's our reference to copy used. + */ + TclDecrRefCount(dir); } if (clientData != NULL) { @@ -1708,7 +1748,7 @@ Tcl_FSGetNormalizedPath(interp, pathPtr) } /* - * Ensure cwd hasn't changed + * Ensure cwd hasn't changed. */ if (fsPathPtr->cwdPtr != NULL) { @@ -1727,41 +1767,40 @@ Tcl_FSGetNormalizedPath(interp, pathPtr) Tcl_Obj *copy; CONST char *cwdStr; ClientData clientData = NULL; - + copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr); Tcl_IncrRefCount(copy); cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); - /* - * Should we perhaps use 'Tcl_FSPathSeparator'? - * But then what about the Windows special case? - * Perhaps we should just check if cwd is a root volume. - * We should never get cwdLen == 0 in this code path. + /* + * Should we perhaps use 'Tcl_FSPathSeparator'? But then what + * about the Windows special case? Perhaps we should just check + * if cwd is a root volume. We should never get cwdLen == 0 in + * this code path. */ switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - if (cwdStr[cwdLen-1] != '/') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - break; - case TCL_PLATFORM_WINDOWS: - if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - break; + case TCL_PLATFORM_UNIX: + if (cwdStr[cwdLen-1] != '/') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + break; + case TCL_PLATFORM_WINDOWS: + if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + break; } Tcl_AppendObjToObj(copy, pathPtr); - /* - * Normalize the combined string, but only starting after - * the end of the previously normalized 'dir'. This should - * be much faster! + /* + * Normalize the combined string, but only starting after the end + * of the previously normalized 'dir'. This should be much faster! */ - TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, + TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); fsPathPtr->normPathPtr = copy; if (clientData != NULL) { @@ -1773,30 +1812,28 @@ Tcl_FSGetNormalizedPath(interp, pathPtr) ClientData clientData = NULL; Tcl_Obj *useThisCwd = NULL; - /* - * Since normPathPtr is NULL, but this is a valid path - * object, we know that the translatedPathPtr cannot be NULL. + /* + * Since normPathPtr is NULL, but this is a valid path object, we know + * that the translatedPathPtr cannot be NULL. */ Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr; CONST char *path = TclGetString(absolutePath); - /* + /* * We have to be a little bit careful here to avoid infinite loops - * we're asking Tcl_FSGetPathType to return the path's type, but - * that call can actually result in a lot of other filesystem - * action, which might loop back through here. + * we're asking Tcl_FSGetPathType to return the path's type, but that + * call can actually result in a lot of other filesystem action, which + * might loop back through here. */ if (path[0] != '\0') { - /* - * We don't ask for the type of 'pathPtr' here, because - * that is not correct for our purposes when we have a - * path like '~'. Tcl has a bit of a contradiction in - * that '~' paths are defined as 'absolute', but in - * reality can be just about anything, depending on - * how env(HOME) is set. + * We don't ask for the type of 'pathPtr' here, because that is + * not correct for our purposes when we have a path like '~'. Tcl + * has a bit of a contradiction in that '~' paths are defined as + * 'absolute', but in reality can be just about anything, + * depending on how env(HOME) is set. */ Tcl_PathType type = Tcl_FSGetPathType(absolutePath); @@ -1810,12 +1847,17 @@ Tcl_FSGetNormalizedPath(interp, pathPtr) absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath); Tcl_IncrRefCount(absolutePath); - /* We have a refCount on the cwd */ + + /* + * We have a refCount on the cwd. + */ #ifdef __WIN32__ } else if (type == TCL_PATH_VOLUME_RELATIVE) { - /* Only Windows has volume-relative paths */ - absolutePath = TclWinVolumeRelativeNormalize(interp, path, - &useThisCwd); + /* + * Only Windows has volume-relative paths. + */ + absolutePath = TclWinVolumeRelativeNormalize(interp, + path, &useThisCwd); if (absolutePath == NULL) { return NULL; } @@ -1824,44 +1866,43 @@ Tcl_FSGetNormalizedPath(interp, pathPtr) } /* - * Already has refCount incremented + * Already has refCount incremented. */ fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, - absolutePath, + absolutePath, (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); if (0 && (clientData != NULL)) { - fsPathPtr->nativePathPtr = + fsPathPtr->nativePathPtr = (*fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc)(clientData); } - /* - * Check if path is pure normalized (this can only be the case - * if it is an absolute path). + /* + * Check if path is pure normalized (this can only be the case if it + * is an absolute path). */ if (useThisCwd == NULL) { if (!strcmp(TclGetString(fsPathPtr->normPathPtr), TclGetString(pathPtr))) { - /* - * The path was already normalized. - * Get rid of the duplicate. + /* + * The path was already normalized. Get rid of the duplicate. */ TclDecrRefCount(fsPathPtr->normPathPtr); - /* - * We do *not* increment the refCount for - * this circular reference + /* + * We do *not* increment the refCount for this circular + * reference. */ fsPathPtr->normPathPtr = pathPtr; } } else { - /* - * We just need to free an object we allocated above for - * relative paths (this was returned by Tcl_FSJoinToPath - * above), and then of course store the cwd. + /* + * We just need to free an object we allocated above for relative + * paths (this was returned by Tcl_FSJoinToPath above), and then + * of course store the cwd. */ TclDecrRefCount(absolutePath); @@ -1877,16 +1918,16 @@ Tcl_FSGetNormalizedPath(interp, pathPtr) * * Tcl_FSGetInternalRep -- * - * Extract the internal representation of a given path object, - * in the given filesystem. If the path object belongs to a - * different filesystem, we return NULL. - * - * If the internal representation is currently NULL, we attempt - * to generate it, by calling the filesystem's - * 'Tcl_FSCreateInternalRepProc'. + * Extract the internal representation of a given path object, in the + * given filesystem. If the path object belongs to a different + * filesystem, we return NULL. + * + * If the internal representation is currently NULL, we attempt to + * generate it, by calling the filesystem's + * 'Tcl_FSCreateInternalRepProc'. * * Results: - * NULL or a valid internal representation. + * NULL or a valid internal representation. * * Side effects: * An attempt may be made to convert the object. @@ -1894,52 +1935,49 @@ Tcl_FSGetNormalizedPath(interp, pathPtr) *--------------------------------------------------------------------------- */ -ClientData +ClientData Tcl_FSGetInternalRep(pathPtr, fsPtr) Tcl_Obj* pathPtr; Tcl_Filesystem *fsPtr; { FsPath* srcFsPathPtr; - + if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) { return NULL; } srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); - - /* + + /* * We will only return the native representation for the caller's - * filesystem. Otherwise we will simply return NULL. This means - * that there must be a unique bi-directional mapping between paths - * and filesystems, and that this mapping will not allow 'remapped' - * files -- files which are in one filesystem but mapped into - * another. Another way of putting this is that 'stacked' - * filesystems are not allowed. We recognise that this is a - * potentially useful feature for the future. - * - * Even something simple like a 'pass through' filesystem which - * logs all activity and passes the calls onto the native system - * would be nice, but not easily achievable with the current - * implementation. + * filesystem. Otherwise we will simply return NULL. This means that + * there must be a unique bi-directional mapping between paths and + * filesystems, and that this mapping will not allow 'remapped' files -- + * files which are in one filesystem but mapped into another. Another way + * of putting this is that 'stacked' filesystems are not allowed. We + * recognise that this is a potentially useful feature for the future. + * + * Even something simple like a 'pass through' filesystem which logs all + * activity and passes the calls onto the native system would be nice, but + * not easily achievable with the current implementation. */ if (srcFsPathPtr->fsRecPtr == NULL) { - /* - * This only usually happens in wrappers like TclpStat which - * create a string object and pass it to TclpObjStat. Code - * which calls the Tcl_FS.. functions should always have a - * filesystem already set. Whether this code path is legal or - * not depends on whether we decide to allow external code to - * call the native filesystem directly. It is at least safer - * to allow this sub-optimal routing. + /* + * This only usually happens in wrappers like TclpStat which create a + * string object and pass it to TclpObjStat. Code which calls the + * Tcl_FS.. functions should always have a filesystem already set. + * Whether this code path is legal or not depends on whether we decide + * to allow external code to call the native filesystem directly. It + * is at least safer to allow this sub-optimal routing. */ Tcl_FSGetFileSystemForPath(pathPtr); - - /* - * If we fail through here, then the path is probably not a - * valid path in the filesystsem, and is most likely to be a - * use of the empty path "" via a direct call to one of the - * objectified interfaces (e.g. from the Tcl testsuite). + + /* + * If we fail through here, then the path is probably not a valid path + * in the filesystsem, and is most likely to be a use of the empty + * path "" via a direct call to one of the objectified interfaces + * (e.g. from the Tcl testsuite). */ srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); @@ -1948,12 +1986,11 @@ Tcl_FSGetInternalRep(pathPtr, fsPtr) } } - /* - * There is still one possibility we should consider; if the file - * belongs to a different filesystem, perhaps it is actually - * linked through to a file in our own filesystem which we do care - * about. The way we can check for this is we ask what filesystem - * this path belongs to. + /* + * There is still one possibility we should consider; if the file belongs + * to a different filesystem, perhaps it is actually linked through to a + * file in our own filesystem which we do care about. The way we can + * check for this is we ask what filesystem this path belongs to. */ if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) { @@ -1983,13 +2020,12 @@ Tcl_FSGetInternalRep(pathPtr, fsPtr) * * TclFSEnsureEpochOk -- * - * This will ensure the pathPtr is up to date and can be - * converted into a "path" type, and that we are able to generate a - * complete normalized path which is used to determine the - * filesystem match. + * This will ensure the pathPtr is up to date and can be converted into a + * "path" type, and that we are able to generate a complete normalized + * path which is used to determine the filesystem match. * * Results: - * Standard Tcl return code. + * Standard Tcl return code. * * Side effects: * An attempt may be made to convert the object. @@ -1997,7 +2033,7 @@ Tcl_FSGetInternalRep(pathPtr, fsPtr) *--------------------------------------------------------------------------- */ -int +int TclFSEnsureEpochOk(pathPtr, fsPtrPtr) Tcl_Obj* pathPtr; Tcl_Filesystem **fsPtrPtr; @@ -2010,15 +2046,14 @@ TclFSEnsureEpochOk(pathPtr, fsPtrPtr) srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); - /* - * Check if the filesystem has changed in some way since - * this object's internal representation was calculated. + /* + * Check if the filesystem has changed in some way since this object's + * internal representation was calculated. */ if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) { - /* - * We have to discard the stale representation and - * recalculate it + /* + * We have to discard the stale representation and recalculate it. */ if (pathPtr->bytes == NULL) { @@ -2033,7 +2068,7 @@ TclFSEnsureEpochOk(pathPtr, fsPtrPtr) } /* - * Check whether the object is already assigned to a fs + * Check whether the object is already assigned to a fs. */ if (srcFsPathPtr->fsRecPtr != NULL) { @@ -2058,26 +2093,29 @@ TclFSEnsureEpochOk(pathPtr, fsPtrPtr) *--------------------------------------------------------------------------- */ -void -TclFSSetPathDetails(pathPtr, fsRecPtr, clientData) +void +TclFSSetPathDetails(pathPtr, fsRecPtr, clientData) Tcl_Obj *pathPtr; FilesystemRecord *fsRecPtr; ClientData clientData; { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); FsPath* srcFsPathPtr; - - /* Make sure pathPtr is of the correct type */ + + /* + * Make sure pathPtr is of the correct type. + */ + if (pathPtr->typePtr != &tclFsPathType) { if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return; } } - + srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); srcFsPathPtr->fsRecPtr = fsRecPtr; srcFsPathPtr->nativePathPtr = clientData; - srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; + srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; fsRecPtr->fileRefCount++; } @@ -2086,11 +2124,11 @@ TclFSSetPathDetails(pathPtr, fsRecPtr, clientData) * * Tcl_FSEqualPaths -- * - * This function tests whether the two paths given are equal path - * objects. If either or both is NULL, 0 is always returned. + * This function tests whether the two paths given are equal path + * objects. If either or both is NULL, 0 is always returned. * * Results: - * 1 or 0. + * 1 or 0. * * Side effects: * None. @@ -2098,7 +2136,7 @@ TclFSSetPathDetails(pathPtr, fsRecPtr, clientData) *--------------------------------------------------------------------------- */ -int +int Tcl_FSEqualPaths(firstPtr, secondPtr) Tcl_Obj* firstPtr; Tcl_Obj* secondPtr; @@ -2119,9 +2157,9 @@ Tcl_FSEqualPaths(firstPtr, secondPtr) return 1; } - /* - * Try the most thorough, correct method of comparing fully - * normalized paths + /* + * Try the most thorough, correct method of comparing fully normalized + * paths. */ tempErrno = Tcl_GetErrno(); @@ -2133,7 +2171,7 @@ Tcl_FSEqualPaths(firstPtr, secondPtr) return 0; } - firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); + firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); return (firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0); } @@ -2143,15 +2181,14 @@ Tcl_FSEqualPaths(firstPtr, secondPtr) * * SetFsPathFromAny -- * - * This function tries to convert the given Tcl_Obj to a valid - * Tcl path type. - * - * The filename may begin with "~" (to indicate current user's - * home directory) or "~<user>" (to indicate any user's home - * directory). + * This function tries to convert the given Tcl_Obj to a valid Tcl path + * type. + * + * The filename may begin with "~" (to indicate current user's home + * directory) or "~<user>" (to indicate any user's home directory). * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * The old representation may be freed, and new memory allocated. @@ -2169,25 +2206,23 @@ SetFsPathFromAny(interp, pathPtr) Tcl_Obj *transPtr; char *name; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - + if (pathPtr->typePtr == &tclFsPathType) { return TCL_OK; } - - /* - * First step is to translate the filename. This is similar to - * Tcl_TranslateFilename, but shouldn't convert everything to - * windows backslashes on that platform. The current - * implementation of this piece is a slightly optimised version - * of the various Tilde/Split/Join stuff to avoid multiple - * split/join operations. - * + + /* + * First step is to translate the filename. This is similar to + * Tcl_TranslateFilename, but shouldn't convert everything to windows + * backslashes on that platform. The current implementation of this piece + * is a slightly optimised version of the various Tilde/Split/Join stuff + * to avoid multiple split/join operations. + * * We remove any trailing directory separator. - * - * However, the split/join routines are quite complex, and - * one has to make sure not to break anything on Unix or Win - * (fCmd.test, fileName.test and cmdAH.test exercise - * most of the code). + * + * However, the split/join routines are quite complex, and one has to make + * sure not to break anything on Unix or Win (fCmd.test, fileName.test and + * cmdAH.test exercise most of the code). */ name = Tcl_GetStringFromObj(pathPtr, &len); @@ -2201,7 +2236,7 @@ SetFsPathFromAny(interp, pathPtr) Tcl_DString temp; int split; char separator='/'; - + split = FindSplitPos(name, separator); if (split != len) { /* We have multiple pieces '~user/foo/bar...' */ @@ -2209,7 +2244,7 @@ SetFsPathFromAny(interp, pathPtr) } /* - * Do some tilde substitution + * Do some tilde substitution. */ if (name[1] == '\0') { @@ -2223,7 +2258,7 @@ SetFsPathFromAny(interp, pathPtr) if (split != len) { name[split] = separator; } - + dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { @@ -2242,11 +2277,11 @@ SetFsPathFromAny(interp, pathPtr) */ Tcl_DStringInit(&temp); - if (TclpGetUserHome(name+1, &temp) == NULL) { + if (TclpGetUserHome(name+1, &temp) == NULL) { if (interp != NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", (name+1), - "\" doesn't exist", (char *) NULL); + Tcl_AppendResult(interp, "user \"", (name+1), + "\" doesn't exist", (char *) NULL); } Tcl_DStringFree(&temp); if (split != len) { @@ -2258,37 +2293,42 @@ SetFsPathFromAny(interp, pathPtr) name[split] = separator; } } - + expandedUser = Tcl_DStringValue(&temp); transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp)); if (split != len) { - /* Join up the tilde substitution with the rest */ - if (name[split+1] == separator) { + /* + * Join up the tilde substitution with the rest. + */ + if (name[split+1] == separator) { /* - * Somewhat tricky case like ~//foo/bar. - * Make use of Split/Join machinery to get it right. - * Assumes all paths beginning with ~ are part of the - * native filesystem. + * Somewhat tricky case like ~//foo/bar. Make use of + * Split/Join machinery to get it right. Assumes all paths + * beginning with ~ are part of the native filesystem. */ int objc; Tcl_Obj **objv; Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL); + Tcl_ListObjGetElements(NULL, parts, &objc, &objv); - /* Skip '~'. It's replaced by its expansion */ + + /* + * Skip '~'. It's replaced by its expansion. + */ + objc--; objv++; while (objc--) { TclpNativeJoinPath(transPtr, TclGetString(*objv++)); } TclDecrRefCount(parts); } else { - /* - * Simple case. "rest" is relative path. Just join it. - * The "rest" object will be freed when - * Tcl_FSJoinToPath returns (unless something else - * claims a refCount on it). + /* + * Simple case. "rest" is relative path. Just join it. The + * "rest" object will be freed when Tcl_FSJoinToPath returns + * (unless something else claims a refCount on it). */ Tcl_Obj *joined; @@ -2311,10 +2351,9 @@ SetFsPathFromAny(interp, pathPtr) char winbuf[MAX_PATH+1]; /* - * In the Cygwin world, call conv_to_win32_path in order to - * use the mount table to translate the file name into - * something Windows will understand. Take care when - * converting empty strings! + * In the Cygwin world, call conv_to_win32_path in order to use the + * mount table to translate the file name into something Windows will + * understand. Take care when converting empty strings! */ name = Tcl_GetStringFromObj(transPtr, &len); @@ -2326,17 +2365,16 @@ SetFsPathFromAny(interp, pathPtr) } #endif /* __CYGWIN__ && __WIN32__ */ - /* - * Now we have a translated filename in 'transPtr'. This will have - * forward slashes on Windows, and will not contain any ~user - * sequences. + /* + * Now we have a translated filename in 'transPtr'. This will have forward + * slashes on Windows, and will not contain any ~user sequences. */ - - fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); + + fsPathPtr = (FsPath *) ckalloc((unsigned)sizeof(FsPath)); fsPathPtr->translatedPathPtr = transPtr; if (transPtr != pathPtr) { - Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); + Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); } fsPathPtr->normPathPtr = NULL; fsPathPtr->cwdPtr = NULL; @@ -2358,7 +2396,7 @@ SetFsPathFromAny(interp, pathPtr) static void FreeFsPathInternalRep(pathPtr) - Tcl_Obj *pathPtr; /* Path object with internal rep to free. */ + Tcl_Obj *pathPtr; /* Path object with internal rep to free. */ { FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr); @@ -2387,8 +2425,11 @@ FreeFsPathInternalRep(pathPtr) if (fsPathPtr->fsRecPtr != NULL) { fsPathPtr->fsRecPtr->fileRefCount--; if (fsPathPtr->fsRecPtr->fileRefCount <= 0) { - /* It has been unregistered already */ - ckfree((char *)fsPathPtr->fsRecPtr); + /* + * It has been unregistered already. + */ + + ckfree((char *) fsPathPtr->fsRecPtr); } } @@ -2413,7 +2454,7 @@ DupFsPathInternalRep(srcPtr, copyPtr) } else { copyFsPathPtr->translatedPathPtr = NULL; } - + if (srcFsPathPtr->normPathPtr != NULL) { copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; if (copyFsPathPtr->normPathPtr != copyPtr) { @@ -2422,7 +2463,7 @@ DupFsPathInternalRep(srcPtr, copyPtr) } else { copyFsPathPtr->normPathPtr = NULL; } - + if (srcFsPathPtr->cwdPtr != NULL) { copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; Tcl_IncrRefCount(copyFsPathPtr->cwdPtr); @@ -2431,13 +2472,13 @@ DupFsPathInternalRep(srcPtr, copyPtr) } copyFsPathPtr->flags = srcFsPathPtr->flags; - - if (srcFsPathPtr->fsRecPtr != NULL + + if (srcFsPathPtr->fsRecPtr != NULL && srcFsPathPtr->nativePathPtr != NULL) { Tcl_FSDupInternalRepProc *dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc; if (dupProc != NULL) { - copyFsPathPtr->nativePathPtr = + copyFsPathPtr->nativePathPtr = (*dupProc)(srcFsPathPtr->nativePathPtr); } else { copyFsPathPtr->nativePathPtr = NULL; @@ -2459,10 +2500,10 @@ DupFsPathInternalRep(srcPtr, copyPtr) * * UpdateStringOfFsPath -- * - * Gives an object a valid string rep. - * + * Gives an object a valid string rep. + * * Results: - * None. + * None. * * Side effects: * Memory may be allocated. @@ -2478,47 +2519,46 @@ UpdateStringOfFsPath(pathPtr) CONST char *cwdStr; int cwdLen; Tcl_Obj *copy; - + if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) { Tcl_Panic("Called UpdateStringOfFsPath with invalid object"); } - + copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr); Tcl_IncrRefCount(copy); - + cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); - /* - * Should we perhaps use 'Tcl_FSPathSeparator'? - * But then what about the Windows special case? - * Perhaps we should just check if cwd is a root volume. - * We should never get cwdLen == 0 in this code path. + /* + * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the + * Windows special case? Perhaps we should just check if cwd is a root + * volume. We should never get cwdLen == 0 in this code path. */ switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - if (cwdStr[cwdLen-1] != '/') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - break; + case TCL_PLATFORM_UNIX: + if (cwdStr[cwdLen-1] != '/') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + break; - case TCL_PLATFORM_WINDOWS: - /* - * We need the extra 'cwdLen != 2', and ':' checks because - * a volume relative path doesn't get a '/'. For example - * 'glob C:*cat*.exe' will return 'C:cat32.exe' - */ + case TCL_PLATFORM_WINDOWS: + /* + * We need the extra 'cwdLen != 2', and ':' checks because a volume + * relative path doesn't get a '/'. For example 'glob C:*cat*.exe' + * will return 'C:cat32.exe' + */ - if (cwdStr[cwdLen-1] != '/' - && cwdStr[cwdLen-1] != '\\') { - if (cwdLen != 2 || cwdStr[1] != ':') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } + if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') { + if (cwdLen != 2 || cwdStr[1] != ':') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; } - break; + } + break; } + Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; @@ -2532,17 +2572,15 @@ UpdateStringOfFsPath(pathPtr) * * TclNativePathInFilesystem -- * - * Any path object is acceptable to the native filesystem, by - * default (we will throw errors when illegal paths are actually - * tried to be used). - * - * However, this behavior means the native filesystem must be - * the last filesystem in the lookup list (otherwise it will - * claim all files belong to it, and other filesystems will - * never get a look in). + * Any path object is acceptable to the native filesystem, by default (we + * will throw errors when illegal paths are actually tried to be used). + * + * However, this behavior means the native filesystem must be the last + * filesystem in the lookup list (otherwise it will claim all files + * belong to it, and other filesystems will never get a look in). * * Results: - * TCL_OK, to indicate 'yes', -1 to indicate no. + * TCL_OK, to indicate 'yes', -1 to indicate no. * * Side effects: * None. @@ -2550,44 +2588,57 @@ UpdateStringOfFsPath(pathPtr) *--------------------------------------------------------------------------- */ -int +int TclNativePathInFilesystem(pathPtr, clientDataPtr) Tcl_Obj *pathPtr; ClientData *clientDataPtr; { - /* - * A special case is required to handle the empty path "". - * This is a valid path (i.e. the user should be able - * to do 'file exists ""' without throwing an error), but - * equally the path doesn't exist. Those are the semantics - * of Tcl (at present anyway), so we have to abide by them - * here. + /* + * A special case is required to handle the empty path "". This is a valid + * path (i.e. the user should be able to do 'file exists ""' without + * throwing an error), but equally the path doesn't exist. Those are the + * semantics of Tcl (at present anyway), so we have to abide by them here. */ if (pathPtr->typePtr == &tclFsPathType) { if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') { - /* We reject the empty path "" */ + /* + * We reject the empty path "". + */ return -1; } - /* Otherwise there is no way this path can be empty */ + /* + * Otherwise there is no way this path can be empty. + */ } else { - /* - * It is somewhat unusual to reach this code path without - * the object being of tclFsPathType. However, we do - * our best to deal with the situation. + /* + * It is somewhat unusual to reach this code path without the object + * being of tclFsPathType. However, we do our best to deal with the + * situation. */ int len; + Tcl_GetStringFromObj(pathPtr, &len); if (len == 0) { - /* We reject the empty path "" */ + /* + * We reject the empty path "". + */ return -1; } } - /* - * Path is of correct type, or is of non-zero length, - * so we accept it. + /* + * Path is of correct type, or is of non-zero length, so we accept it. */ + return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclPipe.c b/generic/tclPipe.c index d4a45cd..4238139 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -1,61 +1,58 @@ /* * tclPipe.c -- * - * This file contains the generic portion of the command channel - * driver as well as various utility routines used in managing - * subprocesses. + * This file contains the generic portion of the command channel driver + * as well as various utility routines used in managing subprocesses. * * Copyright (c) 1997 by Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPipe.c,v 1.10 2004/10/26 20:24:15 davygrvy Exp $ + * RCS: @(#) $Id: tclPipe.c,v 1.11 2005/07/21 14:38:50 dkf Exp $ */ #include "tclInt.h" /* - * A linked list of the following structures is used to keep track - * of child processes that have been detached but haven't exited - * yet, so we can make sure that they're properly "reaped" (officially - * waited for) and don't lie around as zombies cluttering the - * system. + * A linked list of the following structures is used to keep track of child + * processes that have been detached but haven't exited yet, so we can make + * sure that they're properly "reaped" (officially waited for) and don't lie + * around as zombies cluttering the system. */ typedef struct Detached { - Tcl_Pid pid; /* Id of process that's been detached - * but isn't known to have exited. */ - struct Detached *nextPtr; /* Next in list of all detached - * processes. */ + Tcl_Pid pid; /* Id of process that's been detached but + * isn't known to have exited. */ + struct Detached *nextPtr; /* Next in list of all detached processes. */ } Detached; -static Detached *detList = NULL; /* List of all detached proceses. */ -TCL_DECLARE_MUTEX(pipeMutex) /* Guard access to detList. */ +static Detached *detList = NULL;/* List of all detached proceses. */ +TCL_DECLARE_MUTEX(pipeMutex) /* Guard access to detList. */ /* - * Declarations for local procedures defined in this file: + * Declarations for local functions defined in this file: */ -static TclFile FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp, - CONST char *spec, int atOk, CONST char *arg, - CONST char *nextArg, int flags, int *skipPtr, - int *closePtr, int *releasePtr)); +static TclFile FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *spec, int atOk, CONST char *arg, + CONST char *nextArg, int flags, int *skipPtr, + int *closePtr, int *releasePtr)); /* *---------------------------------------------------------------------- * * FileForRedirect -- * - * This procedure does much of the work of parsing redirection - * operators. It handles "@" if specified and allowed, and a file - * name, and opens the file if necessary. + * This function does much of the work of parsing redirection operators. + * It handles "@" if specified and allowed, and a file name, and opens + * the file if necessary. * * Results: - * The return value is the descriptor number for the file. If an - * error occurs then NULL is returned and an error message is left - * in the interp's result. Several arguments are side-effected; see - * the argument list below for details. + * The return value is the descriptor number for the file. If an error + * occurs then NULL is returned and an error message is left in the + * interp's result. Several arguments are side-effected; see the argument + * list below for details. * * Side effects: * None. @@ -67,22 +64,22 @@ static TclFile FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr, releasePtr) Tcl_Interp *interp; /* Intepreter to use for error reporting. */ - CONST char *spec; /* Points to character just after - * redirection character. */ - int atOK; /* Non-zero means that '@' notation can be + CONST char *spec; /* Points to character just after redirection + * character. */ + int atOK; /* Non-zero means that '@' notation can be * used to specify a channel, zero means that * it isn't. */ - CONST char *arg; /* Pointer to entire argument containing - * spec: used for error reporting. */ - CONST char *nextArg; /* Next argument in argc/argv array, if needed - * for file name or channel name. May be + CONST char *arg; /* Pointer to entire argument containing spec: + * used for error reporting. */ + CONST char *nextArg; /* Next argument in argc/argv array, if needed + * for file name or channel name. May be * NULL. */ - int flags; /* Flags to use for opening file or to - * specify mode for channel. */ - int *skipPtr; /* Filled with 1 if redirection target was - * in spec, 2 if it was in nextArg. */ - int *closePtr; /* Filled with one if the caller should - * close the file when done with it, zero + int flags; /* Flags to use for opening file or to specify + * mode for channel. */ + int *skipPtr; /* Filled with 1 if redirection target was in + * spec, 2 if it was in nextArg. */ + int *closePtr; /* Filled with one if the caller should close + * the file when done with it, zero * otherwise. */ int *releasePtr; { @@ -113,11 +110,9 @@ FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr, } *releasePtr = 1; if (writing) { - /* - * Be sure to flush output to the file, so that anything - * written by the child appears after stuff we've already - * written. + * Be sure to flush output to the file, so that anything written + * by the child appears after stuff we've already written. */ Tcl_Flush(chan); @@ -150,7 +145,7 @@ FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr, } return file; - badLastArg: + badLastArg: Tcl_AppendResult(interp, "can't specify \"", arg, "\" as last word in command", (char *) NULL); return NULL; @@ -161,10 +156,9 @@ FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr, * * Tcl_DetachPids -- * - * This procedure is called to indicate that one or more child - * processes have been placed in background and will never be - * waited for; they should eventually be reaped by - * Tcl_ReapDetachedProcs. + * This function is called to indicate that one or more child processes + * have been placed in background and will never be waited for; they + * should eventually be reaped by Tcl_ReapDetachedProcs. * * Results: * None. @@ -177,8 +171,8 @@ FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr, void Tcl_DetachPids(numPids, pidPtr) - int numPids; /* Number of pids to detach: gives size - * of array pointed to by pidPtr. */ + int numPids; /* Number of pids to detach: gives size of + * array pointed to by pidPtr. */ Tcl_Pid *pidPtr; /* Array of pids to detach. */ { register Detached *detPtr; @@ -200,17 +194,16 @@ Tcl_DetachPids(numPids, pidPtr) * * Tcl_ReapDetachedProcs -- * - * This procedure checks to see if any detached processes have - * exited and, if so, it "reaps" them by officially waiting on - * them. It should be called "occasionally" to make sure that - * all detached processes are eventually reaped. + * This function checks to see if any detached processes have exited and, + * if so, it "reaps" them by officially waiting on them. It should be + * called "occasionally" to make sure that all detached processes are + * eventually reaped. * * Results: * None. * * Side effects: - * Processes are waited on, so that they can be reaped by the - * system. + * Processes are waited on, so that they can be reaped by the system. * *---------------------------------------------------------------------- */ @@ -248,19 +241,19 @@ Tcl_ReapDetachedProcs() * * TclCleanupChildren -- * - * This is a utility procedure used to wait for child processes - * to exit, record information about abnormal exits, and then - * collect any stderr output generated by them. + * This is a utility function used to wait for child processes to exit, + * record information about abnormal exits, and then collect any stderr + * output generated by them. * * Results: - * The return value is a standard Tcl result. If anything at - * weird happened with the child processes, TCL_ERROR is returned - * and a message is left in the interp's result. + * The return value is a standard Tcl result. If anything at weird + * happened with the child processes, TCL_ERROR is returned and a message + * is left in the interp's result. * * Side effects: - * If the last character of the interp's result is a newline, then it - * is removed unless keepNewline is non-zero. File errorId gets - * closed, and pidPtr is freed back to the storage allocator. + * If the last character of the interp's result is a newline, then it is + * removed unless keepNewline is non-zero. File errorId gets closed, and + * pidPtr is freed back to the storage allocator. * *---------------------------------------------------------------------- */ @@ -271,7 +264,7 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) int numPids; /* Number of entries in pidPtr array. */ Tcl_Pid *pidPtr; /* Array of process ids of children. */ Tcl_Channel errorChan; /* Channel for file containing stderr output - * from pipeline. NULL means there isn't any + * from pipeline. NULL means there isn't any * stderr output. */ { int result = TCL_OK; @@ -284,11 +277,11 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) abnormalExit = 0; for (i = 0; i < numPids; i++) { /* - * We need to get the resolved pid before we wait on it as - * the windows implimentation of Tcl_WaitPid deletes the - * information such that any following calls to TclpGetPid - * fail. + * We need to get the resolved pid before we wait on it as the windows + * implimentation of Tcl_WaitPid deletes the information such that any + * following calls to TclpGetPid fail. */ + resolvedPid = TclpGetPid(pidPtr[i]); pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0); if (pid == (Tcl_Pid) -1) { @@ -297,9 +290,9 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) msg = Tcl_PosixError(interp); if (errno == ECHILD) { /* - * This changeup in message suggested by Mark Diekhans - * to remind people that ECHILD errors can occur on - * some systems if SIGCHLD isn't in its default state. + * This changeup in message suggested by Mark Diekhans to + * remind people that ECHILD errors can occur on some + * systems if SIGCHLD isn't in its default state. */ msg = @@ -312,10 +305,10 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) } /* - * Create error messages for unusual process exits. An - * extra newline gets appended to each error message, but - * it gets removed below (in the same fashion that an - * extra newline in the command's output is removed). + * Create error messages for unusual process exits. An extra newline + * gets appended to each error message, but it gets removed below (in + * the same fashion that an extra newline in the command's output is + * removed). */ if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { @@ -363,14 +356,12 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) } /* - * Read the standard error file. If there's anything there, - * then return an error and add the file's contents to the result - * string. + * Read the standard error file. If there's anything there, then return an + * error and add the file's contents to the result string. */ anyErrorInfo = 0; if (errorChan != NULL) { - /* * Make sure we start at the beginning of the file. */ @@ -400,8 +391,8 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) } /* - * If a child exited abnormally but didn't output any error information - * at all, generate an error message here. + * If a child exited abnormally but didn't output any error information at + * all, generate an error message here. */ if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) { @@ -416,25 +407,23 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) * * TclCreatePipeline -- * - * Given an argc/argv array, instantiate a pipeline of processes - * as described by the argv. + * Given an argc/argv array, instantiate a pipeline of processes as + * described by the argv. * - * This procedure is unofficially exported for use by BLT. + * This function is unofficially exported for use by BLT. * * Results: - * The return value is a count of the number of new processes - * created, or -1 if an error occurred while creating the pipeline. - * *pidArrayPtr is filled in with the address of a dynamically - * allocated array giving the ids of all of the processes. It - * is up to the caller to free this array when it isn't needed - * anymore. If inPipePtr is non-NULL, *inPipePtr is filled in - * with the file id for the input pipe for the pipeline (if any): - * the caller must eventually close this file. If outPipePtr - * isn't NULL, then *outPipePtr is filled in with the file id - * for the output pipe from the pipeline: the caller must close - * this file. If errFilePtr isn't NULL, then *errFilePtr is filled - * with a file id that may be used to read error output after the - * pipeline completes. + * The return value is a count of the number of new processes created, or + * -1 if an error occurred while creating the pipeline. *pidArrayPtr is + * filled in with the address of a dynamically allocated array giving the + * ids of all of the processes. It is up to the caller to free this array + * when it isn't needed anymore. If inPipePtr is non-NULL, *inPipePtr is + * filled in with the file id for the input pipe for the pipeline (if + * any): the caller must eventually close this file. If outPipePtr isn't + * NULL, then *outPipePtr is filled in with the file id for the output + * pipe from the pipeline: the caller must close this file. If errFilePtr + * isn't NULL, then *errFilePtr is filled with a file id that may be used + * to read error output after the pipeline completes. * * Side effects: * Processes and pipes are created. @@ -448,62 +437,62 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, Tcl_Interp *interp; /* Interpreter to use for error reporting. */ int argc; /* Number of entries in argv. */ CONST char **argv; /* Array of strings describing commands in - * pipeline plus I/O redirection with <, - * <<, >, etc. Argv[argc] must be NULL. */ + * pipeline plus I/O redirection with <, <<, + * >, etc. Argv[argc] must be NULL. */ Tcl_Pid **pidArrayPtr; /* Word at *pidArrayPtr gets filled in with - * address of array of pids for processes - * in pipeline (first pid is first process - * in pipeline). */ + * address of array of pids for processes in + * pipeline (first pid is first process in + * pipeline). */ TclFile *inPipePtr; /* If non-NULL, input to the pipeline comes * from a pipe (unless overridden by - * redirection in the command). The file - * id with which to write to this pipe is - * stored at *inPipePtr. NULL means command - * specified its own input source. */ - TclFile *outPipePtr; /* If non-NULL, output to the pipeline goes - * to a pipe, unless overriden by redirection - * in the command. The file id with which to - * read frome this pipe is stored at - * *outPipePtr. NULL means command specified - * its own output sink. */ + * redirection in the command). The file id + * with which to write to this pipe is stored + * at *inPipePtr. NULL means command specified + * its own input source. */ + TclFile *outPipePtr; /* If non-NULL, output to the pipeline goes to + * a pipe, unless overriden by redirection in + * the command. The file id with which to read + * frome this pipe is stored at *outPipePtr. + * NULL means command specified its own output + * sink. */ TclFile *errFilePtr; /* If non-NULL, all stderr output from the * pipeline will go to a temporary file - * created here, and a descriptor to read - * the file will be left at *errFilePtr. - * The file will be removed already, so - * closing this descriptor will be the end - * of the file. If this is NULL, then - * all stderr output goes to our stderr. - * If the pipeline specifies redirection - * then the file will still be created - * but it will never get any data. */ + * created here, and a descriptor to read the + * file will be left at *errFilePtr. The file + * will be removed already, so closing this + * descriptor will be the end of the file. If + * this is NULL, then all stderr output goes + * to our stderr. If the pipeline specifies + * redirection then the file will still be + * created but it will never get any data. */ { - Tcl_Pid *pidPtr = NULL; /* Points to malloc-ed array holding all - * the pids of child processes. */ - int numPids; /* Actual number of processes that exist - * at *pidPtr right now. */ - int cmdCount; /* Count of number of distinct commands - * found in argc/argv. */ - CONST char *inputLiteral = NULL; /* If non-null, then this points to a - * string containing input data (specified - * via <<) to be piped to the first process - * in the pipeline. */ + Tcl_Pid *pidPtr = NULL; /* Points to malloc-ed array holding all the + * pids of child processes. */ + int numPids; /* Actual number of processes that exist at + * *pidPtr right now. */ + int cmdCount; /* Count of number of distinct commands found + * in argc/argv. */ + CONST char *inputLiteral = NULL; + /* If non-null, then this points to a string + * containing input data (specified via <<) to + * be piped to the first process in the + * pipeline. */ TclFile inputFile = NULL; /* If != NULL, gives file to use as input for * first process in pipeline (specified via < * or <@). */ - int inputClose = 0; /* If non-zero, then inputFile should be + int inputClose = 0; /* If non-zero, then inputFile should be * closed when cleaning up. */ int inputRelease = 0; TclFile outputFile = NULL; /* Writable file for output from last command - * in pipeline (could be file or pipe). NULL + * in pipeline (could be file or pipe). NULL * means use stdout. */ - int outputClose = 0; /* If non-zero, then outputFile should be + int outputClose = 0; /* If non-zero, then outputFile should be * closed when cleaning up. */ int outputRelease = 0; TclFile errorFile = NULL; /* Writable file for error output from all - * commands in pipeline. NULL means use + * commands in pipeline. NULL means use * stderr. */ - int errorClose = 0; /* If non-zero, then errorFile should be + int errorClose = 0; /* If non-zero, then errorFile should be * closed when cleaning up. */ int errorRelease = 0; CONST char *p; @@ -531,16 +520,16 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, numPids = 0; /* - * First, scan through all the arguments to figure out the structure - * of the pipeline. Process all of the input and output redirection - * arguments and remove them from the argument list in the pipeline. - * Count the number of distinct processes (it's the number of "|" - * arguments plus one) but don't remove the "|" arguments because - * they'll be used in the second pass to seperate the individual - * child processes. Cannot start the child processes in this pass - * because the redirection symbols may appear anywhere in the - * command line -- e.g., the '<' that specifies the input to the - * entire pipe may appear at the very end of the argument list. + * First, scan through all the arguments to figure out the structure of + * the pipeline. Process all of the input and output redirection arguments + * and remove them from the argument list in the pipeline. Count the + * number of distinct processes (it's the number of "|" arguments plus + * one) but don't remove the "|" arguments because they'll be used in the + * second pass to seperate the individual child processes. Cannot start + * the child processes in this pass because the redirection symbols may + * appear anywhere in the command line - e.g., the '<' that specifies the + * input to the entire pipe may appear at the very end of the argument + * list. */ lastBar = -1; @@ -556,8 +545,7 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, } if (*p == '\0') { if ((i == (lastBar + 1)) || (i == (argc - 1))) { - Tcl_SetResult(interp, - "illegal use of | or |& in command", + Tcl_SetResult(interp, "illegal use of | or |& in command", TCL_STATIC); goto error; } @@ -590,8 +578,8 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, } } else { inputLiteral = NULL; - inputFile = FileForRedirect(interp, p, 1, argv[i], - argv[i + 1], O_RDONLY, &skip, &inputClose, &inputRelease); + inputFile = FileForRedirect(interp, p, 1, argv[i], argv[i+1], + O_RDONLY, &skip, &inputClose, &inputRelease); if (inputFile == NULL) { goto error; } @@ -616,8 +604,8 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, } /* - * Close the old output file, but only if the error file is - * not also using it. + * Close the old output file, but only if the error file is not + * also using it. */ if (outputClose != 0) { @@ -636,8 +624,8 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, TclpReleaseFile(outputFile); } } - outputFile = FileForRedirect(interp, p, atOK, argv[i], - argv[i + 1], flags, &skip, &outputClose, &outputRelease); + outputFile = FileForRedirect(interp, p, atOK, argv[i], argv[i+1], + flags, &skip, &outputClose, &outputRelease); if (outputFile == NULL) { goto error; } @@ -677,10 +665,11 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, if (atOK && p[0] == '@' && p[1] == '1' && p[2] == '\0') { /* * Special case handling of 2>@1 to redirect stderr to the - * exec/open output pipe as well. This is meant for the end - * of the command string, otherwise use |& between commands. + * exec/open output pipe as well. This is meant for the end of + * the command string, otherwise use |& between commands. */ - if (i != argc - 1) { + + if (i != argc-1) { Tcl_AppendResult(interp, "must specify \"", argv[i], "\" as last word in command", (char *) NULL); goto error; @@ -690,7 +679,7 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, skip = 1; } else { errorFile = FileForRedirect(interp, p, atOK, argv[i], - argv[i + 1], flags, &skip, &errorClose, &errorRelease); + argv[i+1], flags, &skip, &errorClose, &errorRelease); if (errorFile == NULL) { goto error; } @@ -711,9 +700,10 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, if (inputLiteral != NULL) { /* * The input for the first process is immediate data coming from - * Tcl. Create a temporary file for it and put the data into the + * Tcl. Create a temporary file for it and put the data into the * file. */ + inputFile = TclpCreateTempFile(inputLiteral); if (inputFile == NULL) { Tcl_AppendResult(interp, @@ -724,8 +714,8 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, inputClose = 1; } else if (inPipePtr != NULL) { /* - * The input for the first process in the pipeline is to - * come from a pipe that can be written from by the caller. + * The input for the first process in the pipeline is to come from + * a pipe that can be written from by the caller. */ if (TclpCreatePipe(&inputFile, inPipePtr) == 0) { @@ -753,8 +743,8 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, if (outputFile == NULL) { if (outPipePtr != NULL) { /* - * Output from the last process in the pipeline is to go to a - * pipe that can be read by the caller. + * Output from the last process in the pipeline is to go to a pipe + * that can be read by the caller. */ if (TclpCreatePipe(outPipePtr, &outputFile) == 0) { @@ -782,16 +772,17 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, if (errorFile == NULL) { if (errorToOutput == 2) { /* - * Handle 2>@1 special case at end of cmd line + * Handle 2>@1 special case at end of cmd line. */ + errorFile = outputFile; } else if (errFilePtr != NULL) { /* * Set up the standard error output sink for the pipeline, if - * requested. Use a temporary file which is opened, then deleted. + * requested. Use a temporary file which is opened, then deleted. * Could potentially just use pipe, but if it filled up it could - * cause the pipeline to deadlock: we'd be waiting for processes - * to complete before reading stderr, and processes couldn't + * cause the pipeline to deadlock: we'd be waiting for processes + * to complete before reading stderr, and processes couldn't * complete because stderr was backed up. */ @@ -819,8 +810,8 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, } /* - * Scan through the argc array, creating a process for each - * group of arguments between the "|" characters. + * Scan through the argc array, creating a process for each group of + * arguments between the "|" characters. */ Tcl_ReapDetachedProcs(); @@ -861,7 +852,7 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, /* * If this is the last segment, use the specified outputFile. - * Otherwise create an intermediate pipe. pipeIn will become the + * Otherwise create an intermediate pipe. pipeIn will become the * curInFile for the next segment of the pipe. */ @@ -900,8 +891,8 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, numPids++; /* - * Close off our copies of file descriptors that were set up for - * this child, then set up the input for the next child. + * Close off our copies of file descriptors that were set up for this + * child, then set up the input for the next child. */ if ((curInFile != NULL) && (curInFile != inputFile)) { @@ -919,10 +910,10 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, *pidArrayPtr = pidPtr; /* - * All done. Cleanup open files lying around and then return. + * All done. Cleanup open files lying around and then return. */ -cleanup: + cleanup: Tcl_DStringFree(&execBuffer); if (inputClose) { @@ -943,12 +934,12 @@ cleanup: return numPids; /* - * An error occurred. There could have been extra files open, such - * as pipes between children. Clean them all up. Detach any child - * processes that have been created. + * An error occurred. There could have been extra files open, such as + * pipes between children. Clean them all up. Detach any child processes + * that have been created. */ -error: + error: if (pipeIn != NULL) { TclpCloseFile(pipeIn); } @@ -987,28 +978,26 @@ error: * * Tcl_OpenCommandChannel -- * - * Opens an I/O channel to one or more subprocesses specified - * by argc and argv. The flags argument determines the - * disposition of the stdio handles. If the TCL_STDIN flag is - * set then the standard input for the first subprocess will - * be tied to the channel: writing to the channel will provide - * input to the subprocess. If TCL_STDIN is not set, then - * standard input for the first subprocess will be the same as - * this application's standard input. If TCL_STDOUT is set then - * standard output from the last subprocess can be read from the - * channel; otherwise it goes to this application's standard - * output. If TCL_STDERR is set, standard error output for all - * subprocesses is returned to the channel and results in an error - * when the channel is closed; otherwise it goes to this - * application's standard error. If TCL_ENFORCE_MODE is not set, - * then argc and argv can redirect the stdio handles to override - * TCL_STDIN, TCL_STDOUT, and TCL_STDERR; if it is set, then it - * is an error for argc and argv to override stdio channels for - * which TCL_STDIN, TCL_STDOUT, and TCL_STDERR have been set. + * Opens an I/O channel to one or more subprocesses specified by argc and + * argv. The flags argument determines the disposition of the stdio + * handles. If the TCL_STDIN flag is set then the standard input for the + * first subprocess will be tied to the channel: writing to the channel + * will provide input to the subprocess. If TCL_STDIN is not set, then + * standard input for the first subprocess will be the same as this + * application's standard input. If TCL_STDOUT is set then standard + * output from the last subprocess can be read from the channel; + * otherwise it goes to this application's standard output. If TCL_STDERR + * is set, standard error output for all subprocesses is returned to the + * channel and results in an error when the channel is closed; otherwise + * it goes to this application's standard error. If TCL_ENFORCE_MODE is + * not set, then argc and argv can redirect the stdio handles to override + * TCL_STDIN, TCL_STDOUT, and TCL_STDERR; if it is set, then it is an + * error for argc and argv to override stdio channels for which + * TCL_STDIN, TCL_STDOUT, and TCL_STDERR have been set. * * Results: - * A new command channel, or NULL on failure with an error - * message left in interp. + * A new command channel, or NULL on failure with an error message left + * in interp. * * Side effects: * Creates processes, opens pipes. @@ -1018,8 +1007,8 @@ error: Tcl_Channel Tcl_OpenCommandChannel(interp, argc, argv, flags) - Tcl_Interp *interp; /* Interpreter for error reporting. Can - * NOT be NULL. */ + Tcl_Interp *interp; /* Interpreter for error reporting. Can NOT be + * NULL. */ int argc; /* How many arguments. */ CONST char **argv; /* Array of arguments for command pipe. */ int flags; /* Or'ed combination of TCL_STDIN, TCL_STDOUT, @@ -1045,8 +1034,8 @@ Tcl_OpenCommandChannel(interp, argc, argv, flags) } /* - * Verify that the pipes that were created satisfy the - * readable/writable constraints. + * Verify that the pipes that were created satisfy the readable/writable + * constraints. */ if (flags & TCL_ENFORCE_MODE) { @@ -1072,7 +1061,7 @@ Tcl_OpenCommandChannel(interp, argc, argv, flags) } return channel; -error: + error: if (numPids > 0) { Tcl_DetachPids(numPids, pidPtr); ckfree((char *) pidPtr); @@ -1088,3 +1077,11 @@ error: } return NULL; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c index 06070ef..b339607 100644 --- a/generic/tclPkgConfig.c +++ b/generic/tclPkgConfig.c @@ -1,122 +1,137 @@ -/* +/* * tclPkgConfig.c -- * - * This file contains the configuration information to - * embed into the tcl binary library. + * This file contains the configuration information to embed into the tcl + * binary library. * * Copyright (c) 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net> * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPkgConfig.c,v 1.2 2003/06/09 22:48:33 andreas_kupries Exp $ + * RCS: @(#) $Id: tclPkgConfig.c,v 1.3 2005/07/21 14:38:50 dkf Exp $ */ -/* Note, the definitions in this module are influenced by the - * following C preprocessor macros: +/* Note, the definitions in this module are influenced by the following C + * preprocessor macros: * * OSCMa = shortcut for "old style configuration macro activates" * NSCMdt = shortcut for "new style configuration macro declares that" * - * - TCL_THREADS OSCMa compilation as threaded core. - * - TCL_MEM_DEBUG OSCMa memory debugging. - * - TCL_COMPILE_DEBUG OSCMa debugging of bytecode compiler. - * - TCL_COMPILE_STATS OSCMa bytecode compiler statistics. + * - TCL_THREADS OSCMa compilation as threaded core. + * - TCL_MEM_DEBUG OSCMa memory debugging. + * - TCL_COMPILE_DEBUG OSCMa debugging of bytecode compiler. + * - TCL_COMPILE_STATS OSCMa bytecode compiler statistics. * * - TCL_CFG_DO64BIT NSCMdt tcl is compiled for a 64bit system. * - TCL_CFG_DEBUG NSCMdt tcl is compiled with symbol info on. - * - TCL_CFG_OPTIMIZED NSCMdt tcl is compiled with cc optimizations on. + * - TCL_CFG_OPTIMIZED NSCMdt tcl is compiled with cc optimizations on * - TCL_CFG_PROFILED NSCMdt tcl is compiled with profiling info. * * - CFG_RUNTIME_* Paths to various stuff at runtime. * - CFG_INSTALL_* Paths to various stuff at installation time. * * - TCL_CFGVAL_ENCODING string containing the encoding used for the - * configuration values. + * configuration values. */ #include "tclInt.h" - - -/* Use C preprocessor statements to define the various values for the - * embedded configuration information. */ +/* + * Use C preprocessor statements to define the various values for the embedded + * configuration information. + */ #ifdef TCL_THREADS -# define CFG_THREADED "1" +# define CFG_THREADED "1" #else -# define CFG_THREADED "0" +# define CFG_THREADED "0" #endif + #ifdef TCL_MEM_DEBUG -# define CFG_MEMDEBUG "1" +# define CFG_MEMDEBUG "1" #else -# define CFG_MEMDEBUG "0" +# define CFG_MEMDEBUG "0" #endif + #ifdef TCL_COMPILE_DEBUG -# define CFG_COMPILE_DEBUG "1" +# define CFG_COMPILE_DEBUG "1" #else -# define CFG_COMPILE_DEBUG "0" +# define CFG_COMPILE_DEBUG "0" #endif + #ifdef TCL_COMPILE_STATS -# define CFG_COMPILE_STATS "1" +# define CFG_COMPILE_STATS "1" #else -# define CFG_COMPILE_STATS "0" +# define CFG_COMPILE_STATS "0" #endif + #ifdef TCL_CFG_DO64BIT -# define CFG_64 "1" +# define CFG_64 "1" #else -# define CFG_64 "0" +# define CFG_64 "0" #endif + #ifdef TCL_CFG_DEBUG -# define CFG_DEBUG "1" +# define CFG_DEBUG "1" #else -# define CFG_DEBUG "0" +# define CFG_DEBUG "0" #endif + #ifdef TCL_CFG_OPTIMIZED -# define CFG_OPTIMIZED "1" +# define CFG_OPTIMIZED "1" #else -# define CFG_OPTIMIZED "0" +# define CFG_OPTIMIZED "0" #endif + #ifdef TCL_CFG_PROFILED -# define CFG_PROFILED "1" +# define CFG_PROFILED "1" #else -# define CFG_PROFILED "0" +# define CFG_PROFILED "0" #endif -static Tcl_Config cfg [] = { - {"debug", CFG_DEBUG}, - {"threaded", CFG_THREADED}, - {"profiled", CFG_PROFILED}, - {"64bit", CFG_64}, - {"optimized", CFG_OPTIMIZED}, - {"mem_debug", CFG_MEMDEBUG}, - {"compile_debug", CFG_COMPILE_DEBUG}, - {"compile_stats", CFG_COMPILE_STATS}, - - /* Runtime paths to various stuff */ - - {"libdir,runtime", CFG_RUNTIME_LIBDIR}, - {"bindir,runtime", CFG_RUNTIME_BINDIR}, - {"scriptdir,runtime", CFG_RUNTIME_SCRDIR}, - {"includedir,runtime", CFG_RUNTIME_INCDIR}, - {"docdir,runtime", CFG_RUNTIME_DOCDIR}, - - /* Installation paths to various stuff */ - - {"libdir,install", CFG_INSTALL_LIBDIR}, - {"bindir,install", CFG_INSTALL_BINDIR}, - {"scriptdir,install", CFG_INSTALL_SCRDIR}, - {"includedir,install", CFG_INSTALL_INCDIR}, - {"docdir,install", CFG_INSTALL_DOCDIR}, - - /* Last entry, closes the array */ - {NULL, NULL} -}; +static Tcl_Config cfg[] = { + {"debug", CFG_DEBUG}, + {"threaded", CFG_THREADED}, + {"profiled", CFG_PROFILED}, + {"64bit", CFG_64}, + {"optimized", CFG_OPTIMIZED}, + {"mem_debug", CFG_MEMDEBUG}, + {"compile_debug", CFG_COMPILE_DEBUG}, + {"compile_stats", CFG_COMPILE_STATS}, + + /* Runtime paths to various stuff */ + + {"libdir,runtime", CFG_RUNTIME_LIBDIR}, + {"bindir,runtime", CFG_RUNTIME_BINDIR}, + {"scriptdir,runtime", CFG_RUNTIME_SCRDIR}, + {"includedir,runtime", CFG_RUNTIME_INCDIR}, + {"docdir,runtime", CFG_RUNTIME_DOCDIR}, + + /* Installation paths to various stuff */ + + {"libdir,install", CFG_INSTALL_LIBDIR}, + {"bindir,install", CFG_INSTALL_BINDIR}, + {"scriptdir,install", CFG_INSTALL_SCRDIR}, + {"includedir,install", CFG_INSTALL_INCDIR}, + {"docdir,install", CFG_INSTALL_DOCDIR}, + /* Last entry, closes the array */ + {NULL, NULL} +}; + void -TclInitEmbeddedConfigurationInformation (interp) - Tcl_Interp* interp; /* Interpreter the configuration - * command is registered in. */ +TclInitEmbeddedConfigurationInformation(interp) + Tcl_Interp* interp; /* Interpreter the configuration command is + * registered in. */ { - Tcl_RegisterConfig (interp, "tcl", cfg, TCL_CFGVAL_ENCODING); + Tcl_RegisterConfig(interp, "tcl", cfg, TCL_CFGVAL_ENCODING); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclProc.c b/generic/tclProc.c index b3d85c4..8626eaf 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1,16 +1,16 @@ -/* +/* * tclProc.c -- * - * This file contains routines that implement Tcl procedures, - * including the "proc" and "uplevel" commands. + * This file contains routines that implement Tcl procedures, including + * the "proc" and "uplevel" commands. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.77 2005/06/07 21:46:18 dgp Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.78 2005/07/21 14:38:50 dkf Exp $ */ #include "tclInt.h" @@ -27,9 +27,9 @@ static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp, static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -static void InitCompiledLocals _ANSI_ARGS_((Tcl_Interp *interp, +static void InitCompiledLocals _ANSI_ARGS_((Tcl_Interp *interp, ByteCode *codePtr, CompiledLocal *localPtr, - Var *varPtr, Namespace *nsPtr)); + Var *varPtr, Namespace *nsPtr)); /* * The ProcBodyObjType type @@ -37,22 +37,22 @@ static void InitCompiledLocals _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ObjType tclProcBodyType = { "procbody", /* name for this type */ - ProcBodyFree, /* FreeInternalRep procedure */ - ProcBodyDup, /* DupInternalRep procedure */ - NULL, /* UpdateString procedure; Tcl_GetString - * and Tcl_GetStringFromObj should panic + ProcBodyFree, /* FreeInternalRep function */ + ProcBodyDup, /* DupInternalRep function */ + NULL, /* UpdateString function; Tcl_GetString and + * Tcl_GetStringFromObj should panic * instead. */ - NULL /* SetFromAny procedure; Tcl_ConvertToType + NULL /* SetFromAny function; Tcl_ConvertToType * should panic instead. */ }; /* - * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue - * field, encoding the type of level reference in ptr1 and the actual - * parsed out offset in ptr2. + * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field, + * encoding the type of level reference in ptr1 and the actual parsed out + * offset in ptr2. * - * Uses the default behaviour throughout, and never disposes of the - * string rep; it's just a cache type. + * Uses the default behaviour throughout, and never disposes of the string + * rep; it's just a cache type. */ static Tcl_ObjType levelReferenceType = { @@ -65,7 +65,7 @@ static Tcl_ObjType levelReferenceType = { * * Tcl_ProcObjCmd -- * - * This object-based procedure is invoked to process the "proc" Tcl + * This object-based function is invoked to process the "proc" Tcl * command. See the user documentation for details on what it does. * * Results: @@ -99,14 +99,14 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) } /* - * Determine the namespace where the procedure should reside. Unless - * the command name includes namespace qualifiers, this will be the - * current namespace. + * Determine the namespace where the procedure should reside. Unless the + * command name includes namespace qualifiers, this will be the current + * namespace. */ fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL, - 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { Tcl_AppendResult(interp, "can't create procedure \"", fullName, @@ -129,14 +129,15 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) /* * Create the data structure to represent the procedure. */ + if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], &procPtr) != TCL_OK) { return TCL_ERROR; } /* - * Now create a command for the procedure. This will initially be in - * the current namespace unless the procedure's name included namespace + * Now create a command for the procedure. This will initially be in the + * current namespace unless the procedure's name included namespace * qualifiers. To create the new command in the right namespace, we * generate a fully qualified name for it. */ @@ -152,6 +153,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc); Tcl_DStringFree(&ds); + /* * Now initialize the new procedure's cmdPtr field. This will be used * later when the procedure is called to determine what namespace the @@ -166,15 +168,16 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) * procbody), and the argument list is just "args" and the body is empty, * define a compileProc to compile a no-op. * - * Notes: - * - cannot be done for any argument list without having different - * compiled/not-compiled behaviour in the "wrong argument #" case, - * or making this code much more complicated. In any case, it doesn't - * seem to make a lot of sense to verify the number of arguments we - * are about to ignore ... - * - could be enhanced to handle also non-empty bodies that contain - * only comments; however, parsing the body will slow down the - * compilation of all procs whose argument list is just _args_ */ + * Notes: + * - cannot be done for any argument list without having different + * compiled/not-compiled behaviour in the "wrong argument #" case, or + * making this code much more complicated. In any case, it doesn't + * seem to make a lot of sense to verify the number of arguments we + * are about to ignore ... + * - could be enhanced to handle also non-empty bodies that contain only + * comments; however, parsing the body will slow down the compilation + * of all procs whose argument list is just _args_ + */ if (objv[3]->typePtr == &tclProcBodyType) { goto done; @@ -193,9 +196,9 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) goto done; } procArgs++; - } + } - /* + /* * The argument list is just "args"; check the body */ @@ -205,16 +208,16 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) goto done; } procBody++; - } + } - /* + /* * The body is just spaces: link the compileProc */ ((Command *) cmd)->compileProc = TclCompileNoOp; } - done: + done: return TCL_OK; } @@ -223,25 +226,25 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) * * TclCreateProc -- * - * Creates the data associated with a Tcl procedure definition. - * This procedure knows how to handle two types of body objects: - * strings and procbody. Strings are the traditional (and common) value - * for bodies, procbody are values created by extensions that have - * loaded a previously compiled script. + * Creates the data associated with a Tcl procedure definition. This + * function knows how to handle two types of body objects: strings and + * procbody. Strings are the traditional (and common) value for bodies, + * procbody are values created by extensions that have loaded a + * previously compiled script. * * Results: - * Returns TCL_OK on success, along with a pointer to a Tcl - * procedure definition in procPtrPtr where the cmdPtr field is not - * initialised. This definition should be freed by calling - * TclProcCleanupProc() when it is no longer needed. Returns TCL_ERROR if - * anything goes wrong. + * Returns TCL_OK on success, along with a pointer to a Tcl procedure + * definition in procPtrPtr where the cmdPtr field is not initialised. + * This definition should be freed by calling TclProcCleanupProc() when + * it is no longer needed. Returns TCL_ERROR if anything goes wrong. * * Side effects: - * If anything goes wrong, this procedure returns an error - * message in the interpreter. + * If anything goes wrong, this function returns an error message in the + * interpreter. * *---------------------------------------------------------------------- */ + int TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) Tcl_Interp *interp; /* interpreter containing proc */ @@ -280,17 +283,18 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) precompiled = 1; } else { /* - * If the procedure's body object is shared because its string value is - * identical to, e.g., the body of another procedure, we must create a - * private copy for this procedure to use. Such sharing of procedure - * bodies is rare but can cause problems. A procedure body is compiled - * in a context that includes the number of compiler-allocated "slots" - * for local variables. Each formal parameter is given a local variable - * slot (the "procPtr->numCompiledLocals = numArgs" assignment - * below). This means that the same code can not be shared by two - * procedures that have a different number of arguments, even if their - * bodies are identical. Note that we don't use Tcl_DuplicateObj since - * we would not want any bytecode internal representation. + * If the procedure's body object is shared because its string value + * is identical to, e.g., the body of another procedure, we must + * create a private copy for this procedure to use. Such sharing of + * procedure bodies is rare but can cause problems. A procedure body + * is compiled in a context that includes the number of + * compiler-allocated "slots" for local variables. Each formal + * parameter is given a local variable slot (the + * "procPtr->numCompiledLocals = numArgs" assignment below). This + * means that the same code can not be shared by two procedures that + * have a different number of arguments, even if their bodies are + * identical. Note that we don't use Tcl_DuplicateObj since we would + * not want any bytecode internal representation. */ if (Tcl_IsShared(bodyPtr)) { @@ -317,11 +321,11 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) } /* - * Break up the argument list into argument specifiers, then process - * each argument specifier. - * If the body is precompiled, processing is limited to checking that - * the parsed argument is consistent with the one stored in the - * Proc. + * Break up the argument list into argument specifiers, then process each + * argument specifier. If the body is precompiled, processing is limited + * to checking that the parsed argument is consistent with the one stored + * in the Proc. + * * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS. */ @@ -411,10 +415,10 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) if (precompiled) { /* - * Compare the parsed argument with the stored one. - * For the flags, we and out VAR_UNDEFINED to support bridging - * precompiled <= 8.3 code in 8.4 where this is now used as an - * optimization indicator. Yes, this is a hack. -- hobbs + * Compare the parsed argument with the stored one. For the flags, + * we and out VAR_UNDEFINED to support bridging precompiled <= 8.3 + * code in 8.4 where this is now used as an optimization + * indicator. Yes, this is a hack. -- hobbs */ if ((localPtr->nameLength != nameLength) @@ -445,8 +449,8 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { Tcl_AppendResult(interp, "procedure \"", procName, "\": formal parameter \"", fieldValues[0], - "\" has default value inconsistent with precompiled body", - (char *) NULL); + "\" has default value inconsistent with ", + "precompiled body", (char *) NULL); ckfree((char *) fieldValues); goto procError; } @@ -462,10 +466,10 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) } else { /* * Allocate an entry in the runtime procedure frame's array of - * local variables for the argument. + * local variables for the argument. */ - localPtr = (CompiledLocal *) ckalloc((unsigned) + localPtr = (CompiledLocal *) ckalloc((unsigned) (sizeof(CompiledLocal) - sizeof(localPtr->name) + nameLength + 1)); if (procPtr->firstLocalPtr == NULL) { @@ -503,7 +507,7 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) ckfree((char *) argArray); return TCL_OK; -procError: + procError: if (precompiled) { procPtr->refCount--; } else { @@ -532,19 +536,19 @@ procError: * * TclGetFrame -- * - * Given a description of a procedure frame, such as the first - * argument to an "uplevel" or "upvar" command, locate the - * call frame for the appropriate level of procedure. + * Given a description of a procedure frame, such as the first argument + * to an "uplevel" or "upvar" command, locate the call frame for the + * appropriate level of procedure. * * Results: - * The return value is -1 if an error occurred in finding the frame - * (in this case an error message is left in the interp's result). - * 1 is returned if string was either a number or a number preceded - * by "#" and it specified a valid frame. 0 is returned if string - * isn't one of the two things above (in this case, the lookup - * acts as if string were "1"). The variable pointed to by - * framePtrPtr is filled in with the address of the desired frame - * (unless an error occurs, in which case it isn't modified). + * The return value is -1 if an error occurred in finding the frame (in + * this case an error message is left in the interp's result). 1 is + * returned if string was either a number or a number preceded by "#" and + * it specified a valid frame. 0 is returned if string isn't one of the + * two things above (in this case, the lookup acts as if string were + * "1"). The variable pointed to by framePtrPtr is filled in with the + * address of the desired frame (unless an error occurs, in which case it + * isn't modified). * * Side effects: * None. @@ -556,8 +560,8 @@ int TclGetFrame(interp, name, framePtrPtr) Tcl_Interp *interp; /* Interpreter in which to find frame. */ CONST char *name; /* String describing frame. */ - CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL - * if global frame indicated). */ + CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL if + * global frame indicated). */ { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; @@ -583,7 +587,9 @@ TclGetFrame(interp, name, framePtrPtr) result = 0; } - /* Figure out which frame to use, and return it to the caller */ + /* + * Figure out which frame to use, and return it to the caller. + */ if (level == 0) { framePtr = NULL; @@ -601,7 +607,7 @@ TclGetFrame(interp, name, framePtrPtr) *framePtrPtr = framePtr; return result; - levelError: + levelError: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad level \"", name, "\"", (char *) NULL); return -1; @@ -612,19 +618,19 @@ TclGetFrame(interp, name, framePtrPtr) * * TclObjGetFrame -- * - * Given a description of a procedure frame, such as the first - * argument to an "uplevel" or "upvar" command, locate the - * call frame for the appropriate level of procedure. + * Given a description of a procedure frame, such as the first argument + * to an "uplevel" or "upvar" command, locate the call frame for the + * appropriate level of procedure. * * Results: - * The return value is -1 if an error occurred in finding the frame - * (in this case an error message is left in the interp's result). - * 1 is returned if objPtr was either a number or a number preceded - * by "#" and it specified a valid frame. 0 is returned if objPtr - * isn't one of the two things above (in this case, the lookup - * acts as if objPtr were "1"). The variable pointed to by - * framePtrPtr is filled in with the address of the desired frame - * (unless an error occurs, in which case it isn't modified). + * The return value is -1 if an error occurred in finding the frame (in + * this case an error message is left in the interp's result). 1 is + * returned if objPtr was either a number or a number preceded by "#" and + * it specified a valid frame. 0 is returned if objPtr isn't one of the + * two things above (in this case, the lookup acts as if objPtr were + * "1"). The variable pointed to by framePtrPtr is filled in with the + * address of the desired frame (unless an error occurs, in which case it + * isn't modified). * * Side effects: * None. @@ -636,8 +642,8 @@ int TclObjGetFrame(interp, objPtr, framePtrPtr) Tcl_Interp *interp; /* Interpreter in which to find frame. */ Tcl_Obj *objPtr; /* Object describing frame. */ - CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL - * if global frame indicated). */ + CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL if + * global frame indicated). */ { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; @@ -670,9 +676,11 @@ TclObjGetFrame(interp, objPtr, framePtrPtr) if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { goto levelError; } + /* * Cache for future reference. */ + TclFreeIntRep(objPtr); objPtr->typePtr = &levelReferenceType; objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 0; @@ -681,9 +689,11 @@ TclObjGetFrame(interp, objPtr, framePtrPtr) if (Tcl_GetInt(interp, name, &level) != TCL_OK) { return -1; } + /* * Cache for future reference. */ + TclFreeIntRep(objPtr); objPtr->typePtr = &levelReferenceType; objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 1; @@ -693,12 +703,15 @@ TclObjGetFrame(interp, objPtr, framePtrPtr) /* * Don't cache as the object *isn't* a level reference. */ + level = curLevel - 1; result = 0; } } - /* Figure out which frame to use, and return it to the caller */ + /* + * Figure out which frame to use, and return it to the caller. + */ if (level == 0) { framePtr = NULL; @@ -716,7 +729,7 @@ TclObjGetFrame(interp, objPtr, framePtrPtr) *framePtrPtr = framePtr; return result; -levelError: + levelError: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad level \"", name, "\"", (char *) NULL); return -1; @@ -727,8 +740,8 @@ levelError: * * Tcl_UplevelObjCmd -- * - * This object procedure is invoked to process the "uplevel" Tcl - * command. See the user documentation for details on what it does. + * This object function is invoked to process the "uplevel" Tcl command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. @@ -752,7 +765,7 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) CallFrame *savedVarFramePtr, *framePtr; if (objc < 2) { - uplevelSyntax: + uplevelSyntax: Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); return TCL_ERROR; } @@ -787,9 +800,10 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) } else { /* * More than one argument: concatenate them together with spaces - * between, then evaluate the result. Tcl_EvalObjEx will delete - * the object when it decrements its refcount after eval'ing it. + * between, then evaluate the result. Tcl_EvalObjEx will delete the + * object when it decrements its refcount after eval'ing it. */ + Tcl_Obj *objPtr; objPtr = Tcl_ConcatObj(objc, objv); @@ -814,18 +828,17 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) * * TclFindProc -- * - * Given the name of a procedure, return a pointer to the - * record describing the procedure. The procedure will be - * looked up using the usual rules: first in the current - * namespace and then in the global namespace. + * Given the name of a procedure, return a pointer to the record + * describing the procedure. The procedure will be looked up using the + * usual rules: first in the current namespace and then in the global + * namespace. * * Results: - * NULL is returned if the name doesn't correspond to any - * procedure. Otherwise, the return value is a pointer to - * the procedure's record. If the name is found but refers - * to an imported command that points to a "real" procedure - * defined in another namespace, a pointer to that "real" - * procedure's structure is returned. + * NULL is returned if the name doesn't correspond to any procedure. + * Otherwise, the return value is a pointer to the procedure's record. If + * the name is found but refers to an imported command that points to a + * "real" procedure defined in another namespace, a pointer to that + * "real" procedure's structure is returned. * * Side effects: * None. @@ -867,9 +880,9 @@ TclFindProc(iPtr, procName) * Tells whether a command is a Tcl procedure or not. * * Results: - * If the given command is actually a Tcl procedure, the - * return value is the address of the record describing - * the procedure. Otherwise the return value is 0. + * If the given command is actually a Tcl procedure, the return value is + * the address of the record describing the procedure. Otherwise the + * return value is 0. * * Side effects: * None. @@ -898,8 +911,8 @@ TclIsProc(cmdPtr) * * InitCompiledLocals -- * - * This routine is invoked in order to initialize the compiled - * locals table for a new call frame. + * This routine is invoked in order to initialize the compiled locals + * table for a new call frame. * * Results: * None. @@ -922,7 +935,7 @@ InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr) Interp *iPtr = (Interp*) interp; int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr); CompiledLocal *firstLocalPtr; - + if (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS) { /* * This is the first run after a recompile, or else the resolver epoch @@ -931,7 +944,7 @@ InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr) firstLocalPtr = localPtr; for (; localPtr != NULL; localPtr = localPtr->nextPtr) { - + if (localPtr->resolveInfo) { if (localPtr->resolveInfo->deleteProc) { localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); @@ -941,13 +954,13 @@ InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr) localPtr->resolveInfo = NULL; } localPtr->flags &= ~VAR_RESOLVED; - + if (haveResolvers && !(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY))) { ResolverScheme *resPtr = iPtr->resolverPtr; Tcl_ResolvedVarInfo *vinfo; int result; - + if (nsPtr->compiledVarResProc) { result = (*nsPtr->compiledVarResProc)(nsPtr->interp, localPtr->name, localPtr->nameLength, @@ -955,7 +968,7 @@ InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr) } else { result = TCL_CONTINUE; } - + while ((result == TCL_CONTINUE) && resPtr) { if (resPtr->compiledVarResProc) { result = (*resPtr->compiledVarResProc)(nsPtr->interp, @@ -967,18 +980,18 @@ InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr) if (result == TCL_OK) { localPtr->resolveInfo = vinfo; localPtr->flags |= VAR_RESOLVED; - } - } + } + } } localPtr = firstLocalPtr; codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS; } /* - * Initialize the array of local variables stored in the call frame. - * Some variables may have special resolution rules. In that case, - * we call their "resolver" procs to get our hands on the variable, - * and we make the compiled local a link to the real variable. + * Initialize the array of local variables stored in the call frame. Some + * variables may have special resolution rules. In that case, we call + * their "resolver" procs to get our hands on the variable, and we make + * the compiled local a link to the real variable. */ if (haveResolvers) { @@ -992,12 +1005,12 @@ InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr) varPtr->tracePtr = NULL; varPtr->searchPtr = NULL; varPtr->flags = localPtr->flags; - + /* * Now invoke the resolvers to determine the exact variables that * should be used. */ - + resVarInfo = localPtr->resolveInfo; if (resVarInfo && resVarInfo->fetchProc) { Var *resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp, @@ -1028,11 +1041,11 @@ InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr) * * TclInitCompiledLocals -- * - * This routine is invoked in order to initialize the compiled - * locals table for a new call frame. + * This routine is invoked in order to initialize the compiled locals + * table for a new call frame. * - * DEPRECATED: functionality has been inlined elsewhere; this function remains - * to insure binary compatibility with Itcl. + * DEPRECATED: functionality has been inlined elsewhere; this function + * remains to insure binary compatibility with Itcl. * * Results: * None. @@ -1057,7 +1070,7 @@ TclInitCompiledLocals(interp, framePtr, nsPtr) bodyPtr = framePtr->procPtr->bodyPtr; if (bodyPtr->typePtr != &tclByteCodeType) { - Tcl_Panic("body object for proc attached to frame is not a byte code type"); + Tcl_Panic("body object for proc attached to frame is not a byte code type"); } codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; @@ -1069,7 +1082,7 @@ TclInitCompiledLocals(interp, framePtr, nsPtr) * * TclObjInterpProc -- * - * When a Tcl procedure gets invoked during bytecode evaluation, this + * When a Tcl procedure gets invoked during bytecode evaluation, this * object-based routine gets invoked to interpret the procedure. * * Results: @@ -1107,11 +1120,10 @@ TclObjInterpProc(clientData, interp, objc, objv) procName = Tcl_GetStringFromObj(objv[0], &nameLen); /* - * If necessary, compile the procedure's body. The compiler will - * allocate frame slots for the procedure's non-argument local - * variables. Note that compiling the body might increase - * procPtr->numCompiledLocals if new local variables are found - * while compiling. + * If necessary, compile the procedure's body. The compiler will allocate + * frame slots for the procedure's non-argument local variables. Note that + * compiling the body might increase procPtr->numCompiledLocals if new + * local variables are found while compiling. */ result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, @@ -1124,10 +1136,10 @@ TclObjInterpProc(clientData, interp, objc, objv) /* * Set up and push a new call frame for the new procedure invocation. - * This call frame will execute in the proc's namespace, which might - * be different than the current namespace. The proc's namespace is - * that of its command, which can change if the command is renamed - * from one namespace to another. + * This call frame will execute in the proc's namespace, which might be + * different than the current namespace. The proc's namespace is that of + * its command, which can change if the command is renamed from one + * namespace to another. */ framePtrPtr = &framePtr; @@ -1144,9 +1156,9 @@ TclObjInterpProc(clientData, interp, objc, objv) framePtr->procPtr = procPtr; /* - * Create the "compiledLocals" array. Make sure it is large enough to - * hold all the procedure's compiled local variables, including its - * formal parameters. + * Create the "compiledLocals" array. Make sure it is large enough to hold + * all the procedure's compiled local variables, including its formal + * parameters. */ localCt = procPtr->numCompiledLocals; @@ -1155,10 +1167,10 @@ TclObjInterpProc(clientData, interp, objc, objv) framePtr->compiledLocals = compiledLocals; /* - * Match and assign the call's actual parameters to the procedure's - * formal arguments. The formal arguments are described by the first - * numArgs entries in both the Proc structure's local variable list and - * the call frame's local variable array. + * Match and assign the call's actual parameters to the procedure's formal + * arguments. The formal arguments are described by the first numArgs + * entries in both the Proc structure's local variable list and the call + * frame's local variable array. */ numArgs = procPtr->numArgs; @@ -1171,14 +1183,16 @@ TclObjInterpProc(clientData, interp, objc, objv) } else { goto runProc; } - } - imax = ((argCt < numArgs - 1)? argCt : (numArgs - 1)); + } + imax = ((argCt < numArgs - 1)? argCt : (numArgs - 1)); for (i = 1; i <= imax; i++) { /* - * "Normal" arguments; last formal is special, depends on - * it being 'args'. - */ + * "Normal" arguments; last formal is special, depends on it being + * 'args'. + */ + Tcl_Obj *objPtr = objv[i]; + varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* local var is a reference */ varPtr->name = localPtr->name; @@ -1193,11 +1207,13 @@ TclObjInterpProc(clientData, interp, objc, objv) } for (; i < numArgs; i++) { /* - * This loop is entered if argCt < (numArgs-1). - * Set default values; last formal is special. + * This loop is entered if argCt < (numArgs-1). Set default values; + * last formal is special. */ + if (localPtr->defValuePtr != NULL) { Tcl_Obj *objPtr = localPtr->defValuePtr; + varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* local var is a reference */ varPtr->name = localPtr->name; @@ -1215,9 +1231,8 @@ TclObjInterpProc(clientData, interp, objc, objv) } /* - * When we get here, the last formal argument remains - * to be defined: localPtr and varPtr point to the last - * argument to be initialized. + * When we get here, the last formal argument remains to be defined: + * localPtr and varPtr point to the last argument to be initialized. */ if (localPtr->flags & VAR_IS_ARGS) { @@ -1233,27 +1248,31 @@ TclObjInterpProc(clientData, interp, objc, objv) varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* local var is a reference */ } else { - Tcl_Obj **desiredObjs, *argObj; - ByteCode *codePtr; - incorrectArgs: + Tcl_Obj **desiredObjs, *argObj; + ByteCode *codePtr; + /* * Do initialise all compiled locals, to avoid problems at - * DeleteLocalVars. + * DeleteLocalVars. */ + + incorrectArgs: codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr; InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); - /* + /* * Build up desired argument list for Tcl_WrongNumArgs */ desiredObjs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1)); + #ifdef AVOID_HACKS_FOR_ITCL desiredObjs[0] = objv[0]; #else desiredObjs[0] = Tcl_NewListObj(1, objv); #endif /* AVOID_HACKS_FOR_ITCL */ + localPtr = procPtr->firstLocalPtr; for (i=1 ; i<=numArgs ; i++) { TclNewObj(argObj); @@ -1297,15 +1316,16 @@ TclObjInterpProc(clientData, interp, objc, objv) localPtr = localPtr->nextPtr; varPtr++; - runProc: /* * Initialise and resolve the remaining compiledLocals. */ + runProc: if (localPtr) { - ByteCode *codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr; - InitCompiledLocals(interp, codePtr, - localPtr, varPtr, nsPtr); + ByteCode *codePtr = (ByteCode *) + procPtr->bodyPtr->internalRep.otherValuePtr; + + InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); } /* @@ -1336,11 +1356,11 @@ TclObjInterpProc(clientData, interp, objc, objv) } /* - * Pop and free the call frame for this procedure invocation, then - * free the compiledLocals array if malloc'ed storage was used. + * Pop and free the call frame for this procedure invocation, then free + * the compiledLocals array if malloc'ed storage was used. */ - procDone: + procDone: /* * Free the stack-allocated compiled locals and CallFrame. It is important * to pop the call frame without freeing it first: the compiledLocals @@ -1348,10 +1368,10 @@ TclObjInterpProc(clientData, interp, objc, objv) * be deleted. But the compiledLocals must be freed first, as they were * allocated later on the stack. */ - - Tcl_PopCallFrame(interp); /* pop but do not free */ - TclStackFree(interp); /* free compiledLocals */ - TclStackFree(interp); /* free CallFrame */ + + Tcl_PopCallFrame(interp); /* pop but do not free */ + TclStackFree(interp); /* free compiledLocals */ + TclStackFree(interp); /* free CallFrame */ return result; #undef NUM_LOCALS } @@ -1361,18 +1381,17 @@ TclObjInterpProc(clientData, interp, objc, objv) * * TclProcCompileProc -- * - * Called just before a procedure is executed to compile the - * body to byte codes. If the type of the body is not - * "byte code" or if the compile conditions have changed - * (namespace context, epoch counters, etc.) then the body - * is recompiled. Otherwise, this procedure does nothing. + * Called just before a procedure is executed to compile the body to byte + * codes. If the type of the body is not "byte code" or if the compile + * conditions have changed (namespace context, epoch counters, etc.) then + * the body is recompiled. Otherwise, this function does nothing. * * Results: * None. * * Side effects: - * May change the internal representation of the body object - * to compiled code. + * May change the internal representation of the body object to compiled + * code. * *---------------------------------------------------------------------- */ @@ -1382,8 +1401,8 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) Tcl_Interp *interp; /* Interpreter containing procedure. */ Proc *procPtr; /* Data associated with procedure. */ Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr, - * but could be any code fragment compiled - * in the context of this procedure.) */ + * but could be any code fragment compiled in + * the context of this procedure.) */ Namespace *nsPtr; /* Namespace containing procedure. */ CONST char *description; /* string describing this body of code. */ CONST char *procName; /* Name of this procedure. */ @@ -1395,17 +1414,17 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; /* - * If necessary, compile the procedure's body. The compiler will - * allocate frame slots for the procedure's non-argument local - * variables. If the ByteCode already exists, make sure it hasn't been - * invalidated by someone redefining a core command (this might make the - * compiled code wrong). Also, if the code was compiled in/for a - * different interpreter, we recompile it. Note that compiling the body - * might increase procPtr->numCompiledLocals if new local variables are - * found while compiling. + * If necessary, compile the procedure's body. The compiler will allocate + * frame slots for the procedure's non-argument local variables. If the + * ByteCode already exists, make sure it hasn't been invalidated by + * someone redefining a core command (this might make the compiled code + * wrong). Also, if the code was compiled in/for a different interpreter, + * we recompile it. Note that compiling the body might increase + * procPtr->numCompiledLocals if new local variables are found while + * compiling. * - * Precompiled procedure bodies, however, are immutable and therefore - * they are not recompiled, even if things have changed. + * Precompiled procedure bodies, however, are immutable and therefore they + * are not recompiled, even if things have changed. */ if (bodyPtr->typePtr == &tclByteCodeType) { @@ -1430,10 +1449,12 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 1) { /* - * Display a line summarizing the top level command we - * are about to compile. + * Display a line summarizing the top level command we are about + * to compile. */ + Tcl_Obj *message = Tcl_NewStringObj("Compiling ", -1); + Tcl_IncrRefCount(message); Tcl_AppendStringsToObj(message, description, " \"", NULL); TclAppendLimitedToObj(message, procName, -1, 50, NULL); @@ -1443,21 +1464,20 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) #endif /* - * Plug the current procPtr into the interpreter and coerce - * the code body to byte codes. The interpreter needs to - * know which proc it's compiling so that it can access its - * list of compiled locals. + * Plug the current procPtr into the interpreter and coerce the code + * body to byte codes. The interpreter needs to know which proc it's + * compiling so that it can access its list of compiled locals. * - * TRICKY NOTE: Be careful to push a call frame with the - * proper namespace context, so that the byte codes are - * compiled in the appropriate class context. + * TRICKY NOTE: Be careful to push a call frame with the proper + * namespace context, so that the byte codes are compiled in the + * appropriate class context. */ saveProcPtr = iPtr->compiledProcPtr; iPtr->compiledProcPtr = procPtr; result = TclPushStackFrame(interp, &framePtr, - (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0); + (Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0); if (result == TCL_OK) { result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); @@ -1471,6 +1491,7 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); Tcl_Obj *message = Tcl_NewStringObj("\n (compiling ", -1); + Tcl_IncrRefCount(message); Tcl_AppendStringsToObj(message, description, " \"", NULL); TclAppendLimitedToObj(message, procName, -1, 50, NULL); @@ -1485,8 +1506,8 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) } } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { /* - * The resolver epoch has changed, but we only need to invalidate - * the resolver cache. + * The resolver epoch has changed, but we only need to invalidate the + * resolver cache. */ codePtr->flags |= TCL_BYTECODE_RESOLVE_VARS; @@ -1499,26 +1520,26 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) * * ProcessProcResultCode -- * - * Procedure called by TclObjInterpProc to process a return code other + * Function called by TclObjInterpProc to process a return code other * than TCL_OK returned by a Tcl procedure. * * Results: - * Depending on the argument return code, the result returned is - * another return code and the interpreter's result is set to a value - * to supplement that return code. + * Depending on the argument return code, the result returned is another + * return code and the interpreter's result is set to a value to + * supplement that return code. * * Side effects: - * If the result returned is TCL_ERROR, traceback information about - * the procedure just executed is appended to the interpreter's - * errorInfo field. + * If the result returned is TCL_ERROR, traceback information about the + * procedure just executed is appended to the interpreter's errorInfo + * field. * *---------------------------------------------------------------------- */ static int ProcessProcResultCode(interp, procName, nameLen, returnCode) - Tcl_Interp *interp; /* The interpreter in which the procedure - * was called and returned returnCode. */ + Tcl_Interp *interp; /* The interpreter in which the procedure was + * called and returned returnCode. */ char *procName; /* Name of the procedure. Used for error * messages and trace information. */ int nameLen; /* Number of bytes in procedure's name. */ @@ -1535,7 +1556,7 @@ ProcessProcResultCode(interp, procName, nameLen, returnCode) } if (returnCode == TCL_RETURN) { return TclUpdateReturnInfo(iPtr); - } + } if (returnCode != TCL_ERROR) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "invoked \"", @@ -1560,17 +1581,17 @@ ProcessProcResultCode(interp, procName, nameLen, returnCode) * * TclProcDeleteProc -- * - * This procedure is invoked just before a command procedure is - * removed from an interpreter. Its job is to release all the - * resources allocated to the procedure. + * This function is invoked just before a command procedure is removed + * from an interpreter. Its job is to release all the resources allocated + * to the procedure. * * Results: * None. * * Side effects: - * Memory gets freed, unless the procedure is actively being - * executed. In this case the cleanup is delayed until the - * last call to the current procedure completes. + * Memory gets freed, unless the procedure is actively being executed. + * In this case the cleanup is delayed until the last call to the current + * procedure completes. * *---------------------------------------------------------------------- */ @@ -1592,9 +1613,8 @@ TclProcDeleteProc(clientData) * * TclProcCleanupProc -- * - * This procedure does all the real work of freeing up a Proc - * structure. It's called only when the structure's reference - * count becomes zero. + * This function does all the real work of freeing up a Proc structure. + * It's called only when the structure's reference count becomes zero. * * Results: * None. @@ -1644,13 +1664,13 @@ TclProcCleanupProc(procPtr) * * TclUpdateReturnInfo -- * - * This procedure is called when procedures return, and at other - * points where the TCL_RETURN code is used. It examines the - * returnLevel and returnCode to determine the real return status. + * This function is called when procedures return, and at other points + * where the TCL_RETURN code is used. It examines the returnLevel and + * returnCode to determine the real return status. * * Results: - * The return value is the true completion code to use for - * the procedure or script, instead of TCL_RETURN. + * The return value is the true completion code to use for the procedure + * or script, instead of TCL_RETURN. * * Side effects: * None. @@ -1660,8 +1680,8 @@ TclProcCleanupProc(procPtr) int TclUpdateReturnInfo(iPtr) - Interp *iPtr; /* Interpreter for which TCL_RETURN - * exception is being processed. */ + Interp *iPtr; /* Interpreter for which TCL_RETURN exception + * is being processed. */ { int code = TCL_RETURN; @@ -1670,7 +1690,10 @@ TclUpdateReturnInfo(iPtr) Tcl_Panic("TclUpdateReturnInfo: negative return level"); } if (iPtr->returnLevel == 0) { - /* Now we've reached the level to return the requested -code */ + /* + * Now we've reached the level to return the requested -code. + */ + code = iPtr->returnCode; } return code; @@ -1681,13 +1704,13 @@ TclUpdateReturnInfo(iPtr) * * TclGetObjInterpProc -- * - * Returns a pointer to the TclObjInterpProc procedure; this is - * different from the value obtained from the TclObjInterpProc - * reference on systems like Windows where import and export - * versions of a procedure exported by a DLL exist. + * Returns a pointer to the TclObjInterpProc function; this is different + * from the value obtained from the TclObjInterpProc reference on systems + * like Windows where import and export versions of a function exported + * by a DLL exist. * * Results: - * Returns the internal address of the TclObjInterpProc procedure. + * Returns the internal address of the TclObjInterpProc function. * * Side effects: * None. @@ -1707,16 +1730,15 @@ TclGetObjInterpProc() * TclNewProcBodyObj -- * * Creates a new object, of type "procbody", whose internal - * representation is the given Proc struct. The newly created - * object's reference count is 0. + * representation is the given Proc struct. The newly created object's + * reference count is 0. * * Results: * Returns a pointer to a newly allocated Tcl_Obj, 0 on error. * * Side effects: - * The reference count in the ByteCode attached to the Proc is - * bumped up by one, since the internal rep stores a pointer to - * it. + * The reference count in the ByteCode attached to the Proc is bumped up + * by one, since the internal rep stores a pointer to it. * *---------------------------------------------------------------------- */ @@ -1749,9 +1771,8 @@ TclNewProcBodyObj(procPtr) * * ProcBodyDup -- * - * Tcl_ObjType's Dup function for the proc body object. - * Bumps the reference count on the Proc stored in the internal - * representation. + * Tcl_ObjType's Dup function for the proc body object. Bumps the + * reference count on the Proc stored in the internal representation. * * Results: * None. @@ -1779,16 +1800,16 @@ ProcBodyDup(srcPtr, dupPtr) * * ProcBodyFree -- * - * Tcl_ObjType's Free function for the proc body object. The - * reference count on its Proc struct is decreased by 1; if the - * count reaches 0, the proc is freed. + * Tcl_ObjType's Free function for the proc body object. The reference + * count on its Proc struct is decreased by 1; if the count reaches 0, + * the proc is freed. * * Results: * None. * * Side effects: - * If the reference count on the Proc struct reaches 0, the - * struct is freed. + * If the reference count on the Proc struct reaches 0, the struct is + * freed. * *---------------------------------------------------------------------- */ @@ -1809,7 +1830,7 @@ ProcBodyFree(objPtr) * * TclCompileNoOp -- * - * Procedure called to compile no-op's + * Function called to compile no-op's * * Results: * The return value is TCL_OK, indicating successful compilation. @@ -1823,8 +1844,8 @@ ProcBodyFree(objPtr) static int TclCompileNoOp(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; @@ -1836,13 +1857,21 @@ TclCompileNoOp(interp, parsePtr, envPtr) tokenPtr = tokenPtr + tokenPtr->numComponents + 1; envPtr->currStackDepth = savedStackDepth; - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); TclEmitOpcode(INST_POP, envPtr); - } + } } envPtr->currStackDepth = savedStackDepth; TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index dfc7236..98458a6 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -1,16 +1,16 @@ -/* +/* * tclRegexp.c -- * - * This file contains the public interfaces to the Tcl regular - * expression mechanism. + * This file contains the public interfaces to the Tcl regular expression + * mechanism. * * Copyright (c) 1998 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclRegexp.c,v 1.19 2005/05/10 18:34:48 kennykb Exp $ + * RCS: @(#) $Id: tclRegexp.c,v 1.20 2005/07/21 14:38:51 dkf Exp $ */ #include "tclInt.h" @@ -18,8 +18,8 @@ /* *---------------------------------------------------------------------- - * The routines in this file use Henry Spencer's regular expression - * package contained in the following additional source files: + * The routines in this file use Henry Spencer's regular expression package + * contained in the following additional source files: * * regc_color.c regc_cvec.c regc_lex.c * regc_nfa.c regcomp.c regcustom.h @@ -28,23 +28,23 @@ * regfronts.c regguts.h * * Copyright (c) 1998 Henry Spencer. All rights reserved. - * + * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics - * Corporation, none of whom are responsible for the results. The author - * thanks all of them. - * + * Corporation, none of whom are responsible for the results. The author + * thanks all of them. + * * Redistribution and use in source and binary forms -- with or without * modification -- are permitted for any purpose, provided that * redistributions in source form retain this entire copyright notice and * indicate the origin and nature of any modifications. - * - * I'd appreciate being given credit for this package in the documentation - * of software which uses it, but that is not a requirement. - * + * + * I'd appreciate being given credit for this package in the documentation of + * software which uses it, but that is not a requirement. + * * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL + * AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL * HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; @@ -68,15 +68,14 @@ typedef struct ThreadSpecificData { int initialized; /* Set to 1 when the module is initialized. */ - char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled - * regular expression patterns. NULL - * means that this slot isn't used. - * Malloc-ed. */ + char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular + * expression patterns. NULL means that this + * slot isn't used. Malloc-ed. */ int patLengths[NUM_REGEXPS];/* Number of non-null characters in - * corresponding entry in patterns. - * -1 means entry isn't used. */ + * corresponding entry in patterns. -1 means + * entry isn't used. */ struct TclRegexp *regexps[NUM_REGEXPS]; - /* Compiled forms of above strings. Also + /* Compiled forms of above strings. Also * malloc-ed, or NULL if not in use yet. */ } ThreadSpecificData; @@ -100,8 +99,8 @@ static int SetRegexpFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); /* - * The regular expression Tcl object type. This serves as a cache - * of the compiled form of the regular expression. + * The regular expression Tcl object type. This serves as a cache of the + * compiled form of the regular expression. */ Tcl_ObjType tclRegexpType = { @@ -111,24 +110,22 @@ Tcl_ObjType tclRegexpType = { NULL, /* updateStringProc */ SetRegexpFromAny /* setFromAnyProc */ }; - /* *---------------------------------------------------------------------- * * Tcl_RegExpCompile -- * - * Compile a regular expression into a form suitable for fast - * matching. This procedure is DEPRECATED in favor of the - * object version of the command. + * Compile a regular expression into a form suitable for fast matching. + * This function is DEPRECATED in favor of the object version of the + * command. * * Results: - * The return value is a pointer to the compiled form of string, - * suitable for passing to Tcl_RegExpExec. This compiled form - * is only valid up until the next call to this procedure, so - * don't keep these around for a long time! If an error occurred - * while compiling the pattern, then NULL is returned and an error - * message is left in the interp's result. + * The return value is a pointer to the compiled form of string, suitable + * for passing to Tcl_RegExpExec. This compiled form is only valid up + * until the next call to this function, so don't keep these around for a + * long time! If an error occurred while compiling the pattern, then NULL + * is returned and an error message is left in the interp's result. * * Side effects: * Updates the cache of compiled regexps. @@ -138,10 +135,10 @@ Tcl_ObjType tclRegexpType = { Tcl_RegExp Tcl_RegExpCompile(interp, pattern) - Tcl_Interp *interp; /* For use in error reporting and - * to access the interp regexp cache. */ - CONST char *pattern; /* String for which to produce - * compiled regular expression. */ + Tcl_Interp *interp; /* For use in error reporting and to access + * the interp regexp cache. */ + CONST char *pattern; /* String for which to produce compiled + * regular expression. */ { return (Tcl_RegExp) CompileRegexp(interp, pattern, (int) strlen(pattern), REG_ADVANCED); @@ -152,15 +149,14 @@ Tcl_RegExpCompile(interp, pattern) * * Tcl_RegExpExec -- * - * Execute the regular expression matcher using a compiled form - * of a regular expression and save information about any match - * that is found. + * Execute the regular expression matcher using a compiled form of a + * regular expression and save information about any match that is found. * * Results: - * If an error occurs during the matching operation then -1 - * is returned and the interp's result contains an error message. - * Otherwise the return value is 1 if a matching range is - * found and 0 if there is no matching range. + * If an error occurs during the matching operation then -1 is returned + * and the interp's result contains an error message. Otherwise the + * return value is 1 if a matching range is found and 0 if there is no + * matching range. * * Side effects: * None. @@ -171,13 +167,13 @@ Tcl_RegExpCompile(interp, pattern) int Tcl_RegExpExec(interp, re, text, start) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ - Tcl_RegExp re; /* Compiled regular expression; must have - * been returned by previous call to + Tcl_RegExp re; /* Compiled regular expression; must have been + * returned by previous call to * Tcl_GetRegExpFromObj. */ CONST char *text; /* Text against which to match re. */ - CONST char *start; /* If text is part of a larger string, - * this identifies beginning of larger - * string, so that "^" won't match. */ + CONST char *start; /* If text is part of a larger string, this + * identifies beginning of larger string, so + * that "^" won't match. */ { int flags, result, numChars; TclRegexp *regexp = (TclRegexp *)re; @@ -185,8 +181,8 @@ Tcl_RegExpExec(interp, re, text, start) CONST Tcl_UniChar *ustr; /* - * If the starting point is offset from the beginning of the buffer, - * then we need to tell the regexp engine not to match "^". + * If the starting point is offset from the beginning of the buffer, then + * we need to tell the regexp engine not to match "^". */ if (text > start) { @@ -209,8 +205,8 @@ Tcl_RegExpExec(interp, re, text, start) Tcl_DStringInit(&ds); ustr = Tcl_UtfToUniCharDString(text, -1, &ds); numChars = Tcl_DStringLength(&ds) / sizeof(Tcl_UniChar); - result = RegExpExecUniChar(interp, re, ustr, numChars, - -1 /* nmatches */, flags); + result = RegExpExecUniChar(interp, re, ustr, numChars, -1 /* nmatches */, + flags); Tcl_DStringFree(&ds); return result; @@ -226,7 +222,7 @@ Tcl_RegExpExec(interp, re, text, start) * * Results: * The variables at *startPtr and *endPtr are modified to hold the - * addresses of the endpoints of the range given by index. If the + * addresses of the endpoints of the range given by index. If the * specified range doesn't exist then NULLs are returned. * * Side effects: @@ -237,15 +233,15 @@ Tcl_RegExpExec(interp, re, text, start) void Tcl_RegExpRange(re, index, startPtr, endPtr) - Tcl_RegExp re; /* Compiled regular expression that has - * been passed to Tcl_RegExpExec. */ - int index; /* 0 means give the range of the entire - * match, > 0 means give the range of - * a matching subrange. */ + Tcl_RegExp re; /* Compiled regular expression that has been + * passed to Tcl_RegExpExec. */ + int index; /* 0 means give the range of the entire match, + * > 0 means give the range of a matching + * subrange. */ CONST char **startPtr; /* Store address of first character in - * (sub-) range here. */ + * (sub-)range here. */ CONST char **endPtr; /* Store address of character just after last - * in (sub-) range here. */ + * in (sub-)range here. */ { TclRegexp *regexpPtr = (TclRegexp *) re; CONST char *string; @@ -271,14 +267,13 @@ Tcl_RegExpRange(re, index, startPtr, endPtr) * RegExpExecUniChar -- * * Execute the regular expression matcher using a compiled form of a - * regular expression and save information about any match that is - * found. + * regular expression and save information about any match that is found. * * Results: - * If an error occurs during the matching operation then -1 is - * returned and an error message is left in interp's result. - * Otherwise the return value is 1 if a matching range was found or - * 0 if there was no matching range. + * If an error occurs during the matching operation then -1 is returned + * and an error message is left in interp's result. Otherwise the return + * value is 1 if a matching range was found or 0 if there was no matching + * range. * * Side effects: * None. @@ -289,14 +284,14 @@ Tcl_RegExpRange(re, index, startPtr, endPtr) static int RegExpExecUniChar(interp, re, wString, numChars, nmatches, flags) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ - Tcl_RegExp re; /* Compiled regular expression; returned by - * a previous call to Tcl_GetRegExpFromObj */ + Tcl_RegExp re; /* Compiled regular expression; returned by a + * previous call to Tcl_GetRegExpFromObj */ CONST Tcl_UniChar *wString; /* String against which to match re. */ - int numChars; /* Length of Tcl_UniChar string (must - * be >= 0). */ + int numChars; /* Length of Tcl_UniChar string (must be + * >=0). */ int nmatches; /* How many subexpression matches (counting - * the whole match as subexpression 0) are - * of interest. -1 means "don't know". */ + * the whole match as subexpression 0) are of + * interest. -1 means "don't know". */ int flags; /* Regular expression flags. */ { int status; @@ -339,8 +334,8 @@ RegExpExecUniChar(interp, re, wString, numChars, nmatches, flags) * * Results: * The variables at *startPtr and *endPtr are modified to hold the - * offsets of the endpoints of the range given by index. If the - * specified range doesn't exist then -1s are supplied. + * offsets of the endpoints of the range given by index. If the specified + * range doesn't exist then -1s are supplied. * * Side effects: * None. @@ -350,16 +345,16 @@ RegExpExecUniChar(interp, re, wString, numChars, nmatches, flags) void TclRegExpRangeUniChar(re, index, startPtr, endPtr) - Tcl_RegExp re; /* Compiled regular expression that has - * been passed to Tcl_RegExpExec. */ - int index; /* 0 means give the range of the entire - * match, > 0 means give the range of - * a matching subrange, -1 means the - * range of the rm_extend field. */ + Tcl_RegExp re; /* Compiled regular expression that has been + * passed to Tcl_RegExpExec. */ + int index; /* 0 means give the range of the entire match, + * > 0 means give the range of a matching + * subrange, -1 means the range of the + * rm_extend field. */ int *startPtr; /* Store address of first character in - * (sub-) range here. */ + * (sub-)range here. */ int *endPtr; /* Store address of character just after last - * in (sub-) range here. */ + * in (sub-)range here. */ { TclRegexp *regexpPtr = (TclRegexp *) re; @@ -383,10 +378,9 @@ TclRegExpRangeUniChar(re, index, startPtr, endPtr) * See if a string matches a regular expression. * * Results: - * If an error occurs during the matching operation then -1 - * is returned and the interp's result contains an error message. - * Otherwise the return value is 1 if "text" matches "pattern" - * and 0 otherwise. + * If an error occurs during the matching operation then -1 is returned + * and the interp's result contains an error message. Otherwise the + * return value is 1 if "text" matches "pattern" and 0 otherwise. * * Side effects: * None. @@ -417,10 +411,9 @@ Tcl_RegExpMatch(interp, text, pattern) * Execute a precompiled regexp against the given object. * * Results: - * If an error occurs during the matching operation then -1 - * is returned and the interp's result contains an error message. - * Otherwise the return value is 1 if "string" matches "pattern" - * and 0 otherwise. + * If an error occurs during the matching operation then -1 is returned + * and the interp's result contains an error message. Otherwise the + * return value is 1 if "string" matches "pattern" and 0 otherwise. * * Side effects: * Converts the object to a Unicode object. @@ -431,15 +424,15 @@ Tcl_RegExpMatch(interp, text, pattern) int Tcl_RegExpExecObj(interp, re, textObj, offset, nmatches, flags) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ - Tcl_RegExp re; /* Compiled regular expression; must have - * been returned by previous call to + Tcl_RegExp re; /* Compiled regular expression; must have been + * returned by previous call to * Tcl_GetRegExpFromObj. */ Tcl_Obj *textObj; /* Text against which to match re. */ int offset; /* Character index that marks where matching * should begin. */ int nmatches; /* How many subexpression matches (counting - * the whole match as subexpression 0) are - * of interest. -1 means all of them. */ + * the whole match as subexpression 0) are of + * interest. -1 means all of them. */ int flags; /* Regular expression execution flags. */ { TclRegexp *regexpPtr = (TclRegexp *) re; @@ -460,7 +453,7 @@ Tcl_RegExpExecObj(interp, re, textObj, offset, nmatches, flags) } udata += offset; length -= offset; - + return RegExpExecUniChar(interp, re, udata, length, nmatches, flags); } @@ -472,10 +465,9 @@ Tcl_RegExpExecObj(interp, re, textObj, offset, nmatches, flags) * See if an object matches a regular expression. * * Results: - * If an error occurs during the matching operation then -1 - * is returned and the interp's result contains an error message. - * Otherwise the return value is 1 if "text" matches "pattern" - * and 0 otherwise. + * If an error occurs during the matching operation then -1 is returned + * and the interp's result contains an error message. Otherwise the + * return value is 1 if "text" matches "pattern" and 0 otherwise. * * Side effects: * Changes the internal rep of the pattern and string objects. @@ -520,7 +512,7 @@ Tcl_RegExpMatchObj(interp, textObj, patternObj) void Tcl_RegExpGetInfo(regexp, infoPtr) Tcl_RegExp regexp; /* Pattern from which to get subexpressions. */ - Tcl_RegExpInfo *infoPtr; /* Match information is stored here. */ + Tcl_RegExpInfo *infoPtr; /* Match information is stored here. */ { TclRegexp *regexpPtr = (TclRegexp *) regexp; @@ -534,14 +526,14 @@ Tcl_RegExpGetInfo(regexp, infoPtr) * * Tcl_GetRegExpFromObj -- * - * Compile a regular expression into a form suitable for fast - * matching. This procedure caches the result in a Tcl_Obj. + * Compile a regular expression into a form suitable for fast matching. + * This function caches the result in a Tcl_Obj. * * Results: - * The return value is a pointer to the compiled form of string, - * suitable for passing to Tcl_RegExpExec. If an error occurred - * while compiling the pattern, then NULL is returned and an error - * message is left in the interp's result. + * The return value is a pointer to the compiled form of string, suitable + * for passing to Tcl_RegExpExec. If an error occurred while compiling + * the pattern, then NULL is returned and an error message is left in the + * interp's result. * * Side effects: * Updates the native rep of the Tcl_Obj. @@ -554,7 +546,7 @@ Tcl_GetRegExpFromObj(interp, objPtr, flags) 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 + * expression pattern. Internal rep will be * changed to compiled form of this regular * expression. */ int flags; /* Regular expression compilation flags. */ @@ -564,9 +556,10 @@ Tcl_GetRegExpFromObj(interp, objPtr, flags) char *pattern; /* - * This is OK because we only actually interpret this value - * properly as a TclRegexp* when the type is tclRegexpType. + * This is OK because we only actually interpret this value properly as a + * TclRegexp* when the type is tclRegexpType. */ + regexpPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr; if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) { @@ -579,7 +572,7 @@ Tcl_GetRegExpFromObj(interp, objPtr, flags) /* * 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 + * pushed out of the current thread's regexp cache. This reference * will be removed when the object's internal rep is freed. */ @@ -604,10 +597,10 @@ Tcl_GetRegExpFromObj(interp, objPtr, flags) * Return information about a compiled regular expression. * * Results: - * The return value is -1 for failure, 0 for success, although at - * the moment there's nothing that could fail. On success, a list - * is left in the interp's result: first element is the subexpression - * count, second is a list of re_info bit names. + * The return value is -1 for failure, 0 for success, although at the + * moment there's nothing that could fail. On success, a list is left in + * the interp's result: first element is the subexpression count, second + * is a list of re_info bit names. * * Side effects: * None. @@ -651,9 +644,10 @@ TclRegAbout(interp, re) Tcl_AppendElement(interp, buf); /* - * Must count bits before generating list, because we must know - * whether {} are needed before we start appending names. + * Must count bits before generating list, because we must know whether {} + * are needed before we start appending names. */ + n = 0; for (inf = infonames; inf->bit != 0; inf++) { if (regexpPtr->re.re_info&inf->bit) { @@ -711,7 +705,6 @@ TclRegError(interp, msg, status) (VOID) TclReError(REG_ITOA, (regex_t *)NULL, cbuf, sizeof(cbuf)); Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL); } - /* *---------------------------------------------------------------------- @@ -750,8 +743,8 @@ FreeRegexpInternalRep(objPtr) * * DupRegexpInternalRep -- * - * We copy the reference to the compiled regexp and bump its - * reference count. + * We copy the reference to the compiled regexp and bump its reference + * count. * * Results: * None. @@ -768,6 +761,7 @@ DupRegexpInternalRep(srcPtr, copyPtr) Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { TclRegexp *regexpPtr = (TclRegexp *) srcPtr->internalRep.otherValuePtr; + regexpPtr->refCount++; copyPtr->internalRep.otherValuePtr = srcPtr->internalRep.otherValuePtr; copyPtr->typePtr = &tclRegexpType; @@ -809,19 +803,19 @@ SetRegexpFromAny(interp, objPtr) * * CompileRegexp -- * - * Attempt to compile the given regexp pattern. If the compiled - * regular expression can be found in the per-thread cache, it - * will be used instead of compiling a new copy. + * Attempt to compile the given regexp pattern. If the compiled regular + * expression can be found in the per-thread cache, it will be used + * instead of compiling a new copy. * * Results: - * The return value is a pointer to a newly allocated TclRegexp - * that represents the compiled pattern, or NULL if the pattern - * could not be compiled. If NULL is returned, an error message is - * left in the interp's result. + * The return value is a pointer to a newly allocated TclRegexp that + * represents the compiled pattern, or NULL if the pattern could not be + * compiled. If NULL is returned, an error message is left in the + * interp's result. * * Side effects: - * The thread-local regexp cache is updated and a new TclRegexp may - * be allocated. + * The thread-local regexp cache is updated and a new TclRegexp may be + * allocated. * *---------------------------------------------------------------------- */ @@ -839,7 +833,7 @@ CompileRegexp(interp, string, length, flags) Tcl_DString stringBuf; int status, i; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - + if (!tsdPtr->initialized) { tsdPtr->initialized = 1; Tcl_CreateThreadExitHandler(FinalizeRegexp, NULL); @@ -847,14 +841,14 @@ CompileRegexp(interp, string, length, flags) /* * This routine maintains a second-level regular expression cache in - * addition to the per-object regexp cache. The per-thread cache is needed + * addition to the per-object regexp cache. The per-thread cache is needed * to handle the case where for various reasons the object is lost between * invocations of the regexp command, but the literal pattern is the same. */ /* - * Check the per-thread compiled regexp cache. We can only reuse - * a regexp if it has the same pattern and the same flags. + * Check the per-thread compiled regexp cache. We can only reuse a regexp + * if it has the same pattern and the same flags. */ for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) { @@ -862,8 +856,8 @@ CompileRegexp(interp, string, length, flags) && (tsdPtr->regexps[i]->flags == flags) && (strcmp(string, tsdPtr->patterns[i]) == 0)) { /* - * Move the matched pattern to the first slot in the - * cache and shift the other patterns down one position. + * Move the matched pattern to the first slot in the cache and + * shift the other patterns down one position. */ if (i != 0) { @@ -888,7 +882,7 @@ CompileRegexp(interp, string, length, flags) /* * This is a new expression, so compile it and add it to the cache. */ - + regexpPtr = (TclRegexp *) ckalloc(sizeof(TclRegexp)); regexpPtr->objPtr = NULL; regexpPtr->string = NULL; @@ -926,8 +920,8 @@ CompileRegexp(interp, string, length, flags) } /* - * Allocate enough space for all of the subexpressions, plus one - * extra for the entire pattern. + * Allocate enough space for all of the subexpressions, plus one extra for + * the entire pattern. */ regexpPtr->matches = (regmatch_t *) ckalloc( @@ -1024,3 +1018,11 @@ FinalizeRegexp(clientData) ckfree(tsdPtr->patterns[i]); } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclScan.c b/generic/tclScan.c index 2e4bf18..54f9b78 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -1,14 +1,14 @@ -/* +/* * tclScan.c -- * * This file contains the implementation of the "scan" command. * * Copyright (c) 1998 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclScan.c,v 1.17 2005/05/10 18:34:49 kennykb Exp $ + * RCS: @(#) $Id: tclScan.c,v 1.18 2005/07/21 14:38:51 dkf Exp $ */ #include "tclInt.h" @@ -17,23 +17,23 @@ * Flag values used by Tcl_ScanObjCmd. */ -#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ -#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ -#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */ -#define SCAN_WIDTH 0x8 /* A width value was supplied. */ +#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ +#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ +#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */ +#define SCAN_WIDTH 0x8 /* A width value was supplied. */ -#define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */ -#define SCAN_NODIGITS 0x20 /* No digits have been scanned. */ -#define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */ -#define SCAN_XOK 0x80 /* An 'x' is allowed. */ -#define SCAN_PTOK 0x100 /* Decimal point is allowed. */ -#define SCAN_EXPOK 0x200 /* An exponent is allowed. */ +#define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */ +#define SCAN_NODIGITS 0x20 /* No digits have been scanned. */ +#define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */ +#define SCAN_XOK 0x80 /* An 'x' is allowed. */ +#define SCAN_PTOK 0x100 /* Decimal point is allowed. */ +#define SCAN_EXPOK 0x200 /* An exponent is allowed. */ -#define SCAN_LONGER 0x400 /* Asked for a wide value. */ +#define SCAN_LONGER 0x400 /* Asked for a wide value. */ /* - * The following structure contains the information associated with - * a character set. + * The following structure contains the information associated with a + * character set. */ typedef struct CharSet { @@ -62,9 +62,9 @@ static int ValidateFormat _ANSI_ARGS_((Tcl_Interp *interp, char *format, * * BuildCharSet -- * - * This function examines a character set format specification - * and builds a CharSet containing the individual characters and - * character ranges specified. + * This function examines a character set format specification and builds + * a CharSet containing the individual characters and character ranges + * specified. * * Results: * Returns the next format position. @@ -85,7 +85,7 @@ BuildCharSet(cset, format) char *end; memset(cset, 0, sizeof(CharSet)); - + offset = Tcl_UtfToUniChar(format, &ch); if (ch == '^') { cset->exclude = 1; @@ -131,8 +131,8 @@ BuildCharSet(cset, format) while (ch != ']') { if (*format == '-') { /* - * This may be the first character of a range, so don't add - * it yet. + * This may be the first character of a range, so don't add it + * yet. */ start = ch; @@ -159,7 +159,7 @@ BuildCharSet(cset, format) } else { cset->ranges[cset->nranges].start = ch; cset->ranges[cset->nranges].end = start; - } + } cset->nranges++; } } else { @@ -189,8 +189,8 @@ BuildCharSet(cset, format) static int CharInSet(cset, c) CharSet *cset; - int c; /* Character to test, passed as int because - * of non-ANSI prototypes. */ + int c; /* Character to test, passed as int because of + * non-ANSI prototypes. */ { Tcl_UniChar ch = (Tcl_UniChar) c; int i, match = 0; @@ -209,7 +209,7 @@ CharInSet(cset, c) } } } - return (cset->exclude ? !match : match); + return (cset->exclude ? !match : match); } /* @@ -243,8 +243,8 @@ ReleaseCharSet(cset) * * ValidateFormat -- * - * Parse the format string and verify that it is properly formed - * and that there are exactly enough variables on the command line. + * Parse the format string and verify that it is properly formed and that + * there are exactly enough variables on the command line. * * Results: * A standard Tcl result. @@ -259,8 +259,8 @@ static int ValidateFormat(interp, format, numVars, totalSubs) Tcl_Interp *interp; /* Current interpreter. */ char *format; /* The format string. */ - int numVars; /* The number of variables passed to the - * scan command. */ + int numVars; /* The number of variables passed to the scan + * command. */ int *totalSubs; /* The number of variables that will be * required. */ { @@ -274,9 +274,9 @@ ValidateFormat(interp, format, numVars, totalSubs) char buf[TCL_UTF_MAX+1]; /* - * Initialize an array that records the number of times a variable - * is assigned to by the format string. We use this to detect if - * a variable is multiply assigned or left unassigned. + * Initialize an array that records the number of times a variable is + * assigned to by the format string. We use this to detect if a variable + * is multiply assigned or left unassigned. */ if (numVars > nspace) { @@ -309,9 +309,9 @@ ValidateFormat(interp, format, numVars, totalSubs) if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ /* - * Check for an XPG3-style %n$ specification. Note: there - * must not be a mixture of XPG3 specs and non-XPG3 specs - * in the same format string. + * Check for an XPG3-style %n$ specification. Note: there must + * not be a mixture of XPG3 specs and non-XPG3 specs in the same + * format string. */ value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ @@ -331,25 +331,25 @@ ValidateFormat(interp, format, numVars, totalSubs) /* * In the case where no vars are specified, the user can * specify %9999$ legally, so we have to consider special - * rules for growing the assign array. 'value' is - * guaranteed to be > 0. + * rules for growing the assign array. 'value' is guaranteed + * to be > 0. */ xpgSize = (xpgSize > value) ? xpgSize : value; } goto xpgCheckDone; } - notXpg: + notXpg: gotSequential = 1; if (gotXpg) { - mixedXPG: + mixedXPG: Tcl_SetResult(interp, "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC); goto error; } - xpgCheckDone: + xpgCheckDone: /* * Parse any width specifier. */ @@ -381,73 +381,73 @@ ValidateFormat(interp, format, numVars, totalSubs) */ switch (ch) { - case 'c': - if (flags & SCAN_WIDTH) { - Tcl_SetResult(interp, - "field width may not be specified in %c conversion", - TCL_STATIC); - goto error; - } - /* - * Fall through! - */ - case 'n': - case 's': - if (flags & SCAN_LONGER) { - invalidLonger: - buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_AppendResult(interp, - "'l' modifier may not be specified in %", buf, - " conversion", NULL); - goto error; - } - /* - * Fall through! - */ - case 'd': - case 'e': - case 'f': - case 'g': - case 'i': - case 'o': - case 'u': - case 'x': - break; - /* - * Bracket terms need special checking - */ - case '[': - if (flags & SCAN_LONGER) { - goto invalidLonger; - } + case 'c': + if (flags & SCAN_WIDTH) { + Tcl_SetResult(interp, + "field width may not be specified in %c conversion", + TCL_STATIC); + goto error; + } + /* + * Fall through! + */ + case 'n': + case 's': + if (flags & SCAN_LONGER) { + invalidLonger: + buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; + Tcl_AppendResult(interp, + "'l' modifier may not be specified in %", buf, + " conversion", NULL); + goto error; + } + /* + * Fall through! + */ + case 'd': + case 'e': + case 'f': + case 'g': + case 'i': + case 'o': + case 'u': + case 'x': + break; + /* + * Bracket terms need special checking + */ + case '[': + if (flags & SCAN_LONGER) { + goto invalidLonger; + } + if (*format == '\0') { + goto badSet; + } + format += Tcl_UtfToUniChar(format, &ch); + if (ch == '^') { if (*format == '\0') { goto badSet; } format += Tcl_UtfToUniChar(format, &ch); - if (ch == '^') { - if (*format == '\0') { - goto badSet; - } - format += Tcl_UtfToUniChar(format, &ch); - } - if (ch == ']') { - if (*format == '\0') { - goto badSet; - } - format += Tcl_UtfToUniChar(format, &ch); + } + if (ch == ']') { + if (*format == '\0') { + goto badSet; } - while (ch != ']') { - if (*format == '\0') { - goto badSet; - } - format += Tcl_UtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); + } + while (ch != ']') { + if (*format == '\0') { + goto badSet; } - break; - badSet: - Tcl_SetResult(interp, "unmatched [ in format string", - TCL_STATIC); - goto error; - default: + format += Tcl_UtfToUniChar(format, &ch); + } + break; + badSet: + Tcl_SetResult(interp, "unmatched [ in format string", + TCL_STATIC); + goto error; + default: { char buf[TCL_UTF_MAX+1]; @@ -460,10 +460,11 @@ ValidateFormat(interp, format, numVars, totalSubs) if (!(flags & SCAN_SUPPRESS)) { if (objIndex >= nspace) { /* - * Expand the nassign buffer. If we are using XPG specifiers, - * make sure that we grow to a large enough size. xpgSize is + * Expand the nassign buffer. If we are using XPG specifiers, + * make sure that we grow to a large enough size. xpgSize is * guaranteed to be at least one larger than objIndex. */ + value = nspace; if (xpgSize) { nspace = xpgSize; @@ -504,14 +505,19 @@ ValidateFormat(interp, format, numVars, totalSubs) } for (i = 0; i < numVars; i++) { if (nassign[i] > 1) { - Tcl_SetResult(interp, "variable is assigned by multiple \"%n$\" conversion specifiers", TCL_STATIC); + Tcl_SetResult(interp, + "variable is assigned by multiple \"%n$\" conversion specifiers", + TCL_STATIC); goto error; } else if (!xpgSize && (nassign[i] == 0)) { /* - * If the space is empty, and xpgSize is 0 (means XPG wasn't - * used, and/or numVars != 0), then too many vars were given + * If the space is empty, and xpgSize is 0 (means XPG wasn't used, + * and/or numVars != 0), then too many vars were given */ - Tcl_SetResult(interp, "variable is not assigned by any conversion specifiers", TCL_STATIC); + + Tcl_SetResult(interp, + "variable is not assigned by any conversion specifiers", + TCL_STATIC); goto error; } } @@ -521,17 +527,17 @@ ValidateFormat(interp, format, numVars, totalSubs) } return TCL_OK; - badIndex: + badIndex: if (gotXpg) { Tcl_SetResult(interp, "\"%n$\" argument index out of range", TCL_STATIC); } else { - Tcl_SetResult(interp, + Tcl_SetResult(interp, "different numbers of variable names and field specifiers", TCL_STATIC); } - error: + error: if (nassign != staticAssign) { ckfree((char *)nassign); } @@ -544,8 +550,8 @@ ValidateFormat(interp, format, numVars, totalSubs) * * Tcl_ScanObjCmd -- * - * This procedure is invoked to process the "scan" Tcl command. - * See the user documentation for details on what it does. + * This function is invoked to process the "scan" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -581,12 +587,12 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) Tcl_UniChar ch, sch; Tcl_Obj **objs = NULL, *objPtr = NULL; int flags; - char buf[513]; /* Temporary buffer to hold scanned - * number strings before they are - * passed to strtoul. */ + char buf[513]; /* Temporary buffer to hold scanned number + * strings before they are passed to + * strtoul. */ if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, + Tcl_WrongNumArgs(interp, 1, objv, "string format ?varName varName ...?"); return TCL_ERROR; } @@ -597,7 +603,7 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) /* * Check for errors in the format string. */ - + if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) { return TCL_ERROR; } @@ -617,9 +623,9 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) baseString = string; /* - * Iterate over the format string filling in the result objects until - * we reach the end of input, the end of the format string, or there - * is a mismatch. + * Iterate over the format string filling in the result objects until we + * reach the end of input, the end of the format string, or there is a + * mismatch. */ objIndex = 0; @@ -644,9 +650,9 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) } continue; } - + if (ch != '%') { - literal: + literal: if (*string == '\0') { underflow = 1; goto done; @@ -664,15 +670,15 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) } /* - * Check for assignment suppression ('*') or an XPG3-style - * assignment ('%n$'). + * Check for assignment suppression ('*') or an XPG3-style assignment + * ('%n$'). */ if (ch == '*') { flags |= SCAN_SUPPRESS; format += Tcl_UtfToUniChar(format, &ch); - } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ - value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ + } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ + value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ if (*end == '$') { format = end+1; format += Tcl_UtfToUniChar(format, &ch); @@ -684,8 +690,8 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) * Parse any width specifier. */ - if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ - width = strtoul(format-1, &format, 10); /* INTL: "C" locale. */ + if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ + width = strtoul(format-1, &format, 10); /* INTL: "C" locale. */ format += Tcl_UtfToUniChar(format, &ch); } else { width = 0; @@ -711,90 +717,90 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) */ switch (ch) { - case 'n': - if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewIntObj(string - baseString); - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; - } - nconversions++; - continue; + case 'n': + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewIntObj(string - baseString); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + nconversions++; + continue; - case 'd': - op = 'i'; - base = 10; - fn = (long (*) _ANSI_ARGS_((char*,void*,int)))strtol; + case 'd': + op = 'i'; + base = 10; + fn = (long (*) _ANSI_ARGS_((char*,void*,int)))strtol; #ifndef TCL_WIDE_INT_IS_LONG - lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll; + lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll; #endif - break; - case 'i': - op = 'i'; - base = 0; - fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtol; + break; + case 'i': + op = 'i'; + base = 0; + fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtol; #ifndef TCL_WIDE_INT_IS_LONG - lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll; + lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll; #endif - break; - case 'o': - op = 'i'; - base = 8; - fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul; + break; + case 'o': + op = 'i'; + base = 8; + fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul; #ifndef TCL_WIDE_INT_IS_LONG - lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull; + lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull; #endif - break; - case 'x': - op = 'i'; - base = 16; - fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul; + break; + case 'x': + op = 'i'; + base = 16; + fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul; #ifndef TCL_WIDE_INT_IS_LONG - lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull; + lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull; #endif - break; - case 'u': - op = 'i'; - base = 10; - flags |= SCAN_UNSIGNED; - fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul; + break; + case 'u': + op = 'i'; + base = 10; + flags |= SCAN_UNSIGNED; + fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul; #ifndef TCL_WIDE_INT_IS_LONG - lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull; + lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull; #endif - break; + break; - case 'f': - case 'e': - case 'g': - op = 'f'; - break; + case 'f': + case 'e': + case 'g': + op = 'f'; + break; - case 's': - op = 's'; - break; + case 's': + op = 's'; + break; - case 'c': - op = 'c'; - flags |= SCAN_NOSKIP; - break; - case '[': - op = '['; - flags |= SCAN_NOSKIP; - break; + case 'c': + op = 'c'; + flags |= SCAN_NOSKIP; + break; + case '[': + op = '['; + flags |= SCAN_NOSKIP; + break; } /* - * At this point, we will need additional characters from the - * string to proceed. + * At this point, we will need additional characters from the string + * to proceed. */ if (*string == '\0') { underflow = 1; goto done; } - + /* - * Skip any leading whitespace at the beginning of a field unless - * the format suppresses this behavior. + * Skip any leading whitespace at the beginning of a field unless the + * format suppresses this behavior. */ if (!(flags & SCAN_NOSKIP)) { @@ -814,370 +820,370 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) /* * Perform the requested scanning operation. */ - + switch (op) { - case 's': - /* - * Scan a string up to width characters or whitespace. - */ + case 's': + /* + * Scan a string up to width characters or whitespace. + */ - if (width == 0) { - width = (size_t) ~0; - } - end = string; - while (*end != '\0') { - offset = Tcl_UtfToUniChar(end, &sch); - if (Tcl_UniCharIsSpace(sch)) { - break; - } - end += offset; - if (--width == 0) { - break; - } + if (width == 0) { + width = (size_t) ~0; + } + end = string; + while (*end != '\0') { + offset = Tcl_UtfToUniChar(end, &sch); + if (Tcl_UniCharIsSpace(sch)) { + break; } - if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewStringObj(string, end-string); - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; + end += offset; + if (--width == 0) { + break; } - string = end; - break; - - case '[': { - CharSet cset; + } + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewStringObj(string, end-string); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + string = end; + break; - if (width == 0) { - width = (size_t) ~0; - } - end = string; + case '[': { + CharSet cset; - format = BuildCharSet(&cset, format); - while (*end != '\0') { - offset = Tcl_UtfToUniChar(end, &sch); - if (!CharInSet(&cset, (int)sch)) { - break; - } - end += offset; - if (--width == 0) { - break; - } - } - ReleaseCharSet(&cset); + if (width == 0) { + width = (size_t) ~0; + } + end = string; - if (string == end) { - /* - * Nothing matched the range, stop processing - */ - goto done; + format = BuildCharSet(&cset, format); + while (*end != '\0') { + offset = Tcl_UtfToUniChar(end, &sch); + if (!CharInSet(&cset, (int)sch)) { + break; } - if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewStringObj(string, end-string); - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; + end += offset; + if (--width == 0) { + break; } - string = end; - - break; } - case 'c': - /* - * Scan a single Unicode character. - */ + ReleaseCharSet(&cset); - string += Tcl_UtfToUniChar(string, &sch); - if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewIntObj((int)sch); - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; - } - break; - - case 'i': + if (string == end) { /* - * Scan an unsigned or signed integer. + * Nothing matched the range, stop processing. */ + goto done; + } + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewStringObj(string, end-string); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + string = end; - if ((width == 0) || (width > sizeof(buf) - 1)) { - width = sizeof(buf) - 1; - } - flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO; - for (end = buf; width > 0; width--) { - switch (*string) { - /* - * The 0 digit has special meaning at the beginning of - * a number. If we are unsure of the base, it - * indicates that we are in base 8 or base 16 (if it is - * followed by an 'x'). - * - * 8.1 - 8.3.4 incorrectly handled 0x... base-16 - * cases for %x by not reading the 0x as the - * auto-prelude for base-16. [Bug #495213] - */ - case '0': - if (base == 0) { - base = 8; - flags |= SCAN_XOK; - } - if (base == 16) { - flags |= SCAN_XOK; - } - if (flags & SCAN_NOZERO) { - flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS - | SCAN_NOZERO); - } else { - flags &= ~(SCAN_SIGNOK | SCAN_XOK - | SCAN_NODIGITS); - } - goto addToInt; - - case '1': case '2': case '3': case '4': - case '5': case '6': case '7': - if (base == 0) { - base = 10; - } - flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); - goto addToInt; - - case '8': case '9': - if (base == 0) { - base = 10; - } - if (base <= 8) { - break; - } - flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); - goto addToInt; - - case 'A': case 'B': case 'C': - case 'D': case 'E': case 'F': - case 'a': case 'b': case 'c': - case 'd': case 'e': case 'f': - if (base <= 10) { - break; - } - flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); - goto addToInt; - - case '+': case '-': - if (flags & SCAN_SIGNOK) { - flags &= ~SCAN_SIGNOK; - goto addToInt; - } - break; - - case 'x': case 'X': - if ((flags & SCAN_XOK) && (end == buf+1)) { - base = 16; - flags &= ~SCAN_XOK; - goto addToInt; - } - break; - } + break; + } + case 'c': + /* + * Scan a single Unicode character. + */ - /* - * We got an illegal character so we are done accumulating. - */ + string += Tcl_UtfToUniChar(string, &sch); + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewIntObj((int)sch); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + break; - break; + case 'i': + /* + * Scan an unsigned or signed integer. + */ - addToInt: + if ((width == 0) || (width > sizeof(buf) - 1)) { + width = sizeof(buf) - 1; + } + flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO; + for (end = buf; width > 0; width--) { + switch (*string) { /* - * Add the character to the temporary buffer. + * The 0 digit has special meaning at the beginning of a + * number. If we are unsure of the base, it indicates that + * we are in base 8 or base 16 (if it is followed by an + * 'x'). + * + * 8.1 - 8.3.4 incorrectly handled 0x... base-16 cases for + * %x by not reading the 0x as the auto-prelude for + * base-16. [Bug #495213] */ + case '0': + if (base == 0) { + base = 8; + flags |= SCAN_XOK; + } + if (base == 16) { + flags |= SCAN_XOK; + } + if (flags & SCAN_NOZERO) { + flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO); + } else { + flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); + } + goto addToInt; - *end++ = *string++; - if (*string == '\0') { + case '1': case '2': case '3': case '4': + case '5': case '6': case '7': + if (base == 0) { + base = 10; + } + flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); + goto addToInt; + + case '8': case '9': + if (base == 0) { + base = 10; + } + if (base <= 8) { break; } - } + flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); + goto addToInt; + + case 'A': case 'B': case 'C': + case 'D': case 'E': case 'F': + case 'a': case 'b': case 'c': + case 'd': case 'e': case 'f': + if (base <= 10) { + break; + } + flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); + goto addToInt; - /* - * Check to see if we need to back up because we only got a - * sign or a trailing x after a 0. - */ + case '+': case '-': + if (flags & SCAN_SIGNOK) { + flags &= ~SCAN_SIGNOK; + goto addToInt; + } + break; - if (flags & SCAN_NODIGITS) { - if (*string == '\0') { - underflow = 1; + case 'x': case 'X': + if ((flags & SCAN_XOK) && (end == buf+1)) { + base = 16; + flags &= ~SCAN_XOK; + goto addToInt; } - goto done; - } else if (end[-1] == 'x' || end[-1] == 'X') { - end--; - string--; + break; } + /* + * We got an illegal character so we are done accumulating. + */ + + break; + addToInt: /* - * Scan the value from the temporary buffer. If we are - * returning a large unsigned value, we have to convert it back - * to a string since Tcl only supports signed values. + * Add the character to the temporary buffer. */ - if (!(flags & SCAN_SUPPRESS)) { - *end = '\0'; + *end++ = *string++; + if (*string == '\0') { + break; + } + } + + /* + * Check to see if we need to back up because we only got a sign + * or a trailing x after a 0. + */ + + if (flags & SCAN_NODIGITS) { + if (*string == '\0') { + underflow = 1; + } + goto done; + } else if (end[-1] == 'x' || end[-1] == 'X') { + end--; + string--; + } + + /* + * Scan the value from the temporary buffer. If we are returning a + * large unsigned value, we have to convert it back to a string + * since Tcl only supports signed values. + */ + + if (!(flags & SCAN_SUPPRESS)) { + *end = '\0'; #ifndef TCL_WIDE_INT_IS_LONG - if (flags & SCAN_LONGER) { - wideValue = (Tcl_WideInt) (*lfn)(buf, NULL, base); - if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { - /* INTL: ISO digit */ - sprintf(buf, "%" TCL_LL_MODIFIER "u", - (Tcl_WideUInt)wideValue); - objPtr = Tcl_NewStringObj(buf, -1); - } else { - objPtr = Tcl_NewWideIntObj(wideValue); - } + if (flags & SCAN_LONGER) { + wideValue = (Tcl_WideInt) (*lfn)(buf, NULL, base); + if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { + /* INTL: ISO digit */ + sprintf(buf, "%" TCL_LL_MODIFIER "u", + (Tcl_WideUInt)wideValue); + objPtr = Tcl_NewStringObj(buf, -1); } else { + objPtr = Tcl_NewWideIntObj(wideValue); + } + } else { #endif /* !TCL_WIDE_INT_IS_LONG */ - value = (long) (*fn)(buf, NULL, base); - if ((flags & SCAN_UNSIGNED) && (value < 0)) { - sprintf(buf, "%lu", value); /* INTL: ISO digit */ - objPtr = Tcl_NewStringObj(buf, -1); - } else if ((flags & SCAN_LONGER) - || (unsigned long) value > UINT_MAX) { - objPtr = Tcl_NewLongObj(value); - } else { - objPtr = Tcl_NewIntObj(value); - } -#ifndef TCL_WIDE_INT_IS_LONG + value = (long) (*fn)(buf, NULL, base); + if ((flags & SCAN_UNSIGNED) && (value < 0)) { + sprintf(buf, "%lu", value); /* INTL: ISO digit */ + objPtr = Tcl_NewStringObj(buf, -1); + } else if ((flags & SCAN_LONGER) + || (unsigned long) value > UINT_MAX) { + objPtr = Tcl_NewLongObj(value); + } else { + objPtr = Tcl_NewIntObj(value); } -#endif - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; +#ifndef TCL_WIDE_INT_IS_LONG } +#endif + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } - break; + break; - case 'f': - /* - * Scan a floating point number - */ + case 'f': + /* + * Scan a floating point number + */ - if ((width == 0) || (width > sizeof(buf) - 1)) { - width = sizeof(buf) - 1; - } - flags &= ~SCAN_LONGER; - flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_PTOK | SCAN_EXPOK; - for (end = buf; width > 0; width--) { - switch (*string) { - case '0': case '1': case '2': case '3': - case '4': case '5': case '6': case '7': - case '8': case '9': - flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS); - goto addToFloat; - case '+': case '-': - if (flags & SCAN_SIGNOK) { - flags &= ~SCAN_SIGNOK; - goto addToFloat; - } - break; - case '.': - if (flags & SCAN_PTOK) { - flags &= ~(SCAN_SIGNOK | SCAN_PTOK); - goto addToFloat; - } - break; - case 'e': case 'E': - /* - * An exponent is not allowed until there has - * been at least one digit. - */ - - if ((flags & (SCAN_NODIGITS | SCAN_EXPOK)) - == SCAN_EXPOK) { - flags = (flags & ~(SCAN_EXPOK|SCAN_PTOK)) - | SCAN_SIGNOK | SCAN_NODIGITS; - goto addToFloat; - } - break; + if ((width == 0) || (width > sizeof(buf) - 1)) { + width = sizeof(buf) - 1; + } + flags &= ~SCAN_LONGER; + flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_PTOK | SCAN_EXPOK; + for (end = buf; width > 0; width--) { + switch (*string) { + case '0': case '1': case '2': case '3': + case '4': case '5': case '6': case '7': + case '8': case '9': + flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS); + goto addToFloat; + case '+': case '-': + if (flags & SCAN_SIGNOK) { + flags &= ~SCAN_SIGNOK; + goto addToFloat; } - - /* - * We got an illegal character so we are done accumulating. - */ - break; - - addToFloat: + case '.': + if (flags & SCAN_PTOK) { + flags &= ~(SCAN_SIGNOK | SCAN_PTOK); + goto addToFloat; + } + break; + case 'e': case 'E': /* - * Add the character to the temporary buffer. + * An exponent is not allowed until there has been at + * least one digit. */ - *end++ = *string++; - if (*string == '\0') { - break; + if ((flags & (SCAN_NODIGITS | SCAN_EXPOK)) == SCAN_EXPOK) { + flags = (flags & ~(SCAN_EXPOK|SCAN_PTOK)) + | SCAN_SIGNOK | SCAN_NODIGITS; + goto addToFloat; } + break; } /* - * Check to see if we need to back up because we saw a - * trailing 'e' or sign. + * We got an illegal character so we are done accumulating. */ - if (flags & SCAN_NODIGITS) { - if (flags & SCAN_EXPOK) { - /* - * There were no digits at all so scanning has - * failed and we are done. - */ - if (*string == '\0') { - underflow = 1; - } - goto done; - } + break; + + addToFloat: + /* + * Add the character to the temporary buffer. + */ + + *end++ = *string++; + if (*string == '\0') { + break; + } + } + /* + * Check to see if we need to back up because we saw a trailing + * 'e' or sign. + */ + + if (flags & SCAN_NODIGITS) { + if (flags & SCAN_EXPOK) { /* - * We got a bad exponent ('e' and maybe a sign). + * There were no digits at all so scanning has failed and + * we are done. */ - end--; - string--; - if (*end != 'e' && *end != 'E') { - end--; - string--; + if (*string == '\0') { + underflow = 1; } + goto done; } /* - * Scan the value from the temporary buffer. + * We got a bad exponent ('e' and maybe a sign). */ - if (!(flags & SCAN_SUPPRESS)) { - double dvalue; - *end = '\0'; - dvalue = TclStrToD(buf, NULL); - objPtr = Tcl_NewDoubleObj(dvalue); - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; + end--; + string--; + if (*end != 'e' && *end != 'E') { + end--; + string--; } - break; + } + + /* + * Scan the value from the temporary buffer. + */ + + if (!(flags & SCAN_SUPPRESS)) { + double dvalue; + + *end = '\0'; + dvalue = TclStrToD(buf, NULL); + objPtr = Tcl_NewDoubleObj(dvalue); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + break; } nconversions++; } - done: + done: result = 0; code = TCL_OK; if (numVars) { /* - * In this case, variables were specified (classic scan) + * In this case, variables were specified (classic scan). */ + for (i = 0; i < totalVars; i++) { - if (objs[i] != NULL) { - result++; - if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, - objs[i], 0) == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - Tcl_GetString(objv[i+3]), "\"", (char *) NULL); - code = TCL_ERROR; - } - Tcl_DecrRefCount(objs[i]); + if (objs[i] == NULL) { + continue; + } + result++; + if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", + TclGetString(objv[i+3]), "\"", (char *) NULL); + code = TCL_ERROR; } + Tcl_DecrRefCount(objs[i]); } } else { /* * Here no vars were specified, we want a list returned (inline scan) */ + objPtr = Tcl_NewObj(); for (i = 0; i < totalVars; i++) { if (objs[i] != NULL) { @@ -1185,9 +1191,10 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) Tcl_DecrRefCount(objs[i]); } else { /* - * More %-specifiers than matching chars, so we - * just spit out empty strings for these + * More %-specifiers than matching chars, so we just spit out + * empty strings for these. */ + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj()); } } @@ -1213,3 +1220,11 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) } return code; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclThread.c b/generic/tclThread.c index 2afc284..766e984 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -1,24 +1,23 @@ /* * tclThread.c -- * - * This file implements Platform independent thread operations. - * Most of the real work is done in the platform dependent files. + * This file implements Platform independent thread operations. Most of + * the real work is done in the platform dependent files. * * Copyright (c) 1998 by Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclThread.c,v 1.11 2005/05/10 18:34:50 kennykb Exp $ + * RCS: @(#) $Id: tclThread.c,v 1.12 2005/07/21 14:38:51 dkf Exp $ */ #include "tclInt.h" /* - * There are three classes of synchronization objects: - * mutexes, thread data keys, and condition variables. - * The following are used to record the memory used for these - * objects so they can be finalized. + * There are three classes of synchronization objects: mutexes, thread data + * keys, and condition variables. The following are used to record the memory + * used for these objects so they can be finalized. * * These statics are guarded by the mutex in the caller of * TclRememberThreadData, e.g., TclpThreadDataKeyInit @@ -35,7 +34,7 @@ static SyncObjRecord mutexRecord = {0, 0, NULL}; static SyncObjRecord condRecord = {0, 0, NULL}; /* - * Prototypes of functions used only in this file + * Prototypes of functions used only in this file. */ static void RememberSyncObject _ANSI_ARGS_((char *objPtr, @@ -45,9 +44,10 @@ static void ForgetSyncObject _ANSI_ARGS_((char *objPtr, /* * Several functions are #defined to nothing in tcl.h if TCL_THREADS is not - * specified. Here we undo that so the procedures are defined in the - * stubs table. + * specified. Here we undo that so the functions are defined in the stubs + * table. */ + #ifndef TCL_THREADS #undef Tcl_MutexLock #undef Tcl_MutexUnlock @@ -63,15 +63,15 @@ static void ForgetSyncObject _ANSI_ARGS_((char *objPtr, * * Tcl_GetThreadData -- * - * This procedure allocates and initializes a chunk of thread - * local storage. + * This function allocates and initializes a chunk of thread local + * storage. * * Results: * A thread-specific pointer to the data structure. * * Side effects: - * Will allocate memory the first time this thread calls for - * this chunk of storage. + * Will allocate memory the first time this thread calls for this chunk + * of storage. * *---------------------------------------------------------------------- */ @@ -131,11 +131,11 @@ Tcl_GetThreadData(keyPtr, size) * * TclThreadDataKeyGet -- * - * This procedure returns a pointer to a block of thread local storage. + * This function returns a pointer to a block of thread local storage. * * Results: - * A thread-specific pointer to the data structure, or NULL - * if the memory has not been assigned to this key for this thread. + * A thread-specific pointer to the data structure, or NULL if the memory + * has not been assigned to this key for this thread. * * Side effects: * None. @@ -145,8 +145,8 @@ Tcl_GetThreadData(keyPtr, size) VOID * TclThreadDataKeyGet(keyPtr) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really + * (pthread_key_t **) */ { #ifdef TCL_THREADS #ifdef USE_THREAD_STORAGE @@ -166,7 +166,7 @@ TclThreadDataKeyGet(keyPtr) * * TclThreadDataKeySet -- * - * This procedure sets a thread local storage pointer. + * This function sets a thread local storage pointer. * * Results: * None. @@ -179,11 +179,12 @@ TclThreadDataKeyGet(keyPtr) void TclThreadDataKeySet(keyPtr, data) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really + * (pthread_key_t **) */ VOID *data; /* Thread local storage */ { #ifdef TCL_THREADS + if (*keyPtr == NULL) { #ifdef USE_THREAD_STORAGE TclThreadStorageDataKeyInit(keyPtr); @@ -191,13 +192,15 @@ TclThreadDataKeySet(keyPtr, data) TclpThreadDataKeyInit(keyPtr); #endif /* USE_THREAD_STORAGE */ } + #ifdef USE_THREAD_STORAGE TclThreadStorageDataKeySet(keyPtr, data); #else TclpThreadDataKeySet(keyPtr, data); #endif /* USE_THREAD_STORAGE */ + #else /* TCL_THREADS */ - *keyPtr = (Tcl_ThreadDataKey)data; + *keyPtr = (Tcl_ThreadDataKey) data; #endif /* TCL_THREADS */ } @@ -206,8 +209,8 @@ TclThreadDataKeySet(keyPtr, data) * * RememberSyncObject * - * Keep a list of (mutexes/condition variable/data key) - * used during finalization. + * Keep a list of (mutexes/condition variable/data key) used during + * finalization. * * Results: * None. @@ -227,18 +230,18 @@ RememberSyncObject(objPtr, recPtr) int i, j; /* - * Save the pointer to the allocated object so it can be finalized. - * Grow the list of pointers if necessary, copying only non-NULL - * pointers to the new list. + * Save the pointer to the allocated object so it can be finalized. Grow + * the list of pointers if necessary, copying only non-NULL pointers to + * the new list. */ if (recPtr->num >= recPtr->max) { recPtr->max += 8; newList = (char **)ckalloc(recPtr->max * sizeof(char *)); for (i=0,j=0 ; i<recPtr->num ; i++) { - if (recPtr->list[i] != NULL) { + if (recPtr->list[i] != NULL) { newList[j++] = recPtr->list[i]; - } + } } if (recPtr->list != NULL) { ckfree((char *)recPtr->list); @@ -255,7 +258,7 @@ RememberSyncObject(objPtr, recPtr) * * ForgetSyncObject * - * Remove a single object from the list. + * Remove a single object from the list. * * Results: * None. @@ -286,7 +289,7 @@ ForgetSyncObject(objPtr, recPtr) * * TclRememberMutex * - * Keep a list of mutexes used during finalization. + * Keep a list of mutexes used during finalization. * * Results: * None. @@ -309,8 +312,8 @@ TclRememberMutex(mutexPtr) * * Tcl_MutexFinalize -- * - * Finalize a single mutex and remove it from the - * list of remembered objects. + * Finalize a single mutex and remove it from the list of remembered + * objects. * * Results: * None. @@ -336,7 +339,7 @@ Tcl_MutexFinalize(mutexPtr) * * TclRememberDataKey * - * Keep a list of thread data keys used during finalization. + * Keep a list of thread data keys used during finalization. * * Results: * None. @@ -359,7 +362,7 @@ TclRememberDataKey(keyPtr) * * TclRememberCondition * - * Keep a list of condition variables used during finalization. + * Keep a list of condition variables used during finalization. * * Results: * None. @@ -382,8 +385,8 @@ TclRememberCondition(condPtr) * * Tcl_ConditionFinalize -- * - * Finalize a single condition variable and remove it from the - * list of remembered objects. + * Finalize a single condition variable and remove it from the list of + * remembered objects. * * Results: * None. @@ -409,8 +412,8 @@ Tcl_ConditionFinalize(condPtr) * * TclFinalizeThreadData -- * - * This procedure cleans up the thread-local storage. This is - * called once for each thread. + * This function cleans up the thread-local storage. This is called once + * for each thread. * * Results: * None. @@ -425,11 +428,11 @@ void TclFinalizeThreadData() { int i; - Tcl_ThreadDataKey *keyPtr; TclpMasterLock(); for (i=0 ; i<keyRecord.num ; i++) { - keyPtr = (Tcl_ThreadDataKey *) keyRecord.list[i]; + Tcl_ThreadDataKey *keyPtr = (Tcl_ThreadDataKey *) keyRecord.list[i]; + #ifdef TCL_THREADS #ifdef USE_THREAD_STORAGE TclFinalizeThreadStorageData(keyPtr); @@ -451,8 +454,8 @@ TclFinalizeThreadData() * * TclFinalizeSynchronization -- * - * This procedure cleans up all synchronization objects: - * mutexes, condition variables, and thread-local storage. + * This function cleans up all synchronization objects: mutexes, + * condition variables, and thread-local storage. * * Results: * None. @@ -539,9 +542,9 @@ TclFinalizeSynchronization() * * Tcl_ExitThread -- * - * This procedure is called to terminate the current thread. - * This should be used by extensions that create threads with - * additional interpreters in them. + * This function is called to terminate the current thread. This should + * be used by extensions that create threads with additional interpreters + * in them. * * Results: * None. @@ -569,10 +572,9 @@ Tcl_ExitThread(status) * * Tcl_ConditionWait, et al. -- * - * These noop procedures are provided so the stub table does - * not have to be conditionalized for threads. The real - * implementations of these functions live in the platform - * specific files. + * These noop functions are provided so the stub table does not have to + * be conditionalized for threads. The real implementations of these + * functions live in the platform specific files. * * Results: * None. @@ -613,3 +615,11 @@ Tcl_MutexUnlock(mutexPtr) { } #endif /* !TCL_THREADS */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 7a5494a..fbd37e6 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -5,10 +5,10 @@ * * Copyright (c) 1997-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUtf.c,v 1.34 2005/05/10 18:34:51 kennykb Exp $ + * RCS: @(#) $Id: tclUtf.c,v 1.35 2005/07/21 14:38:51 dkf Exp $ */ #include "tclInt.h" @@ -20,35 +20,35 @@ #include "tclUniData.c" /* - * The following macros are used for fast character category tests. The - * x_BITS values are shifted right by the category value to determine whether - * the given category is included in the set. + * The following macros are used for fast character category tests. The x_BITS + * values are shifted right by the category value to determine whether the + * given category is included in the set. */ #define ALPHA_BITS ((1 << UPPERCASE_LETTER) | (1 << LOWERCASE_LETTER) \ - | (1 << TITLECASE_LETTER) | (1 << MODIFIER_LETTER) | (1 << OTHER_LETTER)) + | (1 << TITLECASE_LETTER) | (1 << MODIFIER_LETTER) | (1<<OTHER_LETTER)) #define DIGIT_BITS (1 << DECIMAL_DIGIT_NUMBER) #define SPACE_BITS ((1 << SPACE_SEPARATOR) | (1 << LINE_SEPARATOR) \ - | (1 << PARAGRAPH_SEPARATOR)) + | (1 << PARAGRAPH_SEPARATOR)) #define CONNECTOR_BITS (1 << CONNECTOR_PUNCTUATION) #define PRINT_BITS (ALPHA_BITS | DIGIT_BITS | SPACE_BITS | \ - (1 << NON_SPACING_MARK) | (1 << ENCLOSING_MARK) | \ - (1 << COMBINING_SPACING_MARK) | (1 << LETTER_NUMBER) | \ - (1 << OTHER_NUMBER) | (1 << CONNECTOR_PUNCTUATION) | \ - (1 << DASH_PUNCTUATION) | (1 << OPEN_PUNCTUATION) | \ - (1 << CLOSE_PUNCTUATION) | (1 << INITIAL_QUOTE_PUNCTUATION) | \ - (1 << FINAL_QUOTE_PUNCTUATION) | (1 << OTHER_PUNCTUATION) | \ - (1 << MATH_SYMBOL) | (1 << CURRENCY_SYMBOL) | \ - (1 << MODIFIER_SYMBOL) | (1 << OTHER_SYMBOL)) + (1 << NON_SPACING_MARK) | (1 << ENCLOSING_MARK) | \ + (1 << COMBINING_SPACING_MARK) | (1 << LETTER_NUMBER) | \ + (1 << OTHER_NUMBER) | (1 << CONNECTOR_PUNCTUATION) | \ + (1 << DASH_PUNCTUATION) | (1 << OPEN_PUNCTUATION) | \ + (1 << CLOSE_PUNCTUATION) | (1 << INITIAL_QUOTE_PUNCTUATION) | \ + (1 << FINAL_QUOTE_PUNCTUATION) | (1 << OTHER_PUNCTUATION) | \ + (1 << MATH_SYMBOL) | (1 << CURRENCY_SYMBOL) | \ + (1 << MODIFIER_SYMBOL) | (1 << OTHER_SYMBOL)) #define PUNCT_BITS ((1 << CONNECTOR_PUNCTUATION) | \ - (1 << DASH_PUNCTUATION) | (1 << OPEN_PUNCTUATION) | \ - (1 << CLOSE_PUNCTUATION) | (1 << INITIAL_QUOTE_PUNCTUATION) | \ - (1 << FINAL_QUOTE_PUNCTUATION) | (1 << OTHER_PUNCTUATION)) + (1 << DASH_PUNCTUATION) | (1 << OPEN_PUNCTUATION) | \ + (1 << CLOSE_PUNCTUATION) | (1 << INITIAL_QUOTE_PUNCTUATION) | \ + (1 << FINAL_QUOTE_PUNCTUATION) | (1 << OTHER_PUNCTUATION)) /* * Unicode characters less than this value are represented by themselves @@ -93,7 +93,6 @@ static CONST unsigned char totalBytes[256] = { */ static int UtfCount _ANSI_ARGS_((int ch)); - /* *--------------------------------------------------------------------------- @@ -144,11 +143,11 @@ UtfCount(ch) * Tcl_UniCharToUtf -- * * Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the - * provided buffer. Equivalent to Plan 9 runetochar(). + * provided buffer. Equivalent to Plan 9 runetochar(). * * Results: - * The return values is the number of bytes in the buffer that - * were consumed. + * The return values is the number of bytes in the buffer that were + * consumed. * * Side effects: * None. @@ -160,9 +159,9 @@ INLINE int Tcl_UniCharToUtf(ch, buf) int ch; /* The Tcl_UniChar to be stored in the * buffer. */ - char *buf; /* Buffer in which the UTF-8 representation - * of the Tcl_UniChar is stored. Buffer must - * be large enough to hold the UTF-8 character + char *buf; /* Buffer in which the UTF-8 representation of + * the Tcl_UniChar is stored. Buffer must be + * large enough to hold the UTF-8 character * (at most TCL_UTF_MAX bytes). */ { if ((ch > 0) && (ch < UNICODE_SELF)) { @@ -222,8 +221,8 @@ Tcl_UniCharToUtf(ch, buf) * * Results: * The return value is a pointer to the UTF-8 representation of the - * Unicode string. Storage for the return value is appended to the - * end of dsPtr. + * Unicode string. Storage for the return value is appended to the end of + * dsPtr. * * Side effects: * None. @@ -236,9 +235,8 @@ Tcl_UniCharToUtfDString(uniStr, uniLength, dsPtr) CONST Tcl_UniChar *uniStr; /* Unicode string to convert to UTF-8. */ int uniLength; /* Length of Unicode string in Tcl_UniChars * (must be >= 0). */ - Tcl_DString *dsPtr; /* UTF-8 representation of string is - * appended to this previously initialized - * DString. */ + Tcl_DString *dsPtr; /* UTF-8 representation of string is appended + * to this previously initialized DString. */ { CONST Tcl_UniChar *w, *wEnd; char *p, *string; @@ -269,16 +267,16 @@ Tcl_UniCharToUtfDString(uniStr, uniLength, dsPtr) * * Tcl_UtfToUniChar -- * - * Extract the Tcl_UniChar represented by the UTF-8 string. Bad - * UTF-8 sequences are converted to valid Tcl_UniChars and processing - * continues. Equivalent to Plan 9 chartorune(). + * Extract the Tcl_UniChar represented by the UTF-8 string. Bad UTF-8 + * sequences are converted to valid Tcl_UniChars and processing + * continues. Equivalent to Plan 9 chartorune(). * - * The caller must ensure that the source buffer is long enough that - * this routine does not run off the end and dereference non-existent - * memory looking for trail bytes. If the source buffer is known to - * be '\0' terminated, this cannot happen. Otherwise, the caller - * should call Tcl_UtfCharComplete() before calling this routine to - * ensure that enough bytes remain in the string. + * The caller must ensure that the source buffer is long enough that this + * routine does not run off the end and dereference non-existent memory + * looking for trail bytes. If the source buffer is known to be '\0' + * terminated, this cannot happen. Otherwise, the caller should call + * Tcl_UtfCharComplete() before calling this routine to ensure that + * enough bytes remain in the string. * * Results: * *chPtr is filled with the Tcl_UniChar, and the return value is the @@ -293,8 +291,8 @@ Tcl_UniCharToUtfDString(uniStr, uniLength, dsPtr) int Tcl_UtfToUniChar(src, chPtr) register CONST char *src; /* The UTF-8 string. */ - register Tcl_UniChar *chPtr; /* Filled with the Tcl_UniChar represented - * by the UTF-8 string. */ + register Tcl_UniChar *chPtr; /* Filled with the Tcl_UniChar represented by + * the UTF-8 string. */ { register int byte; @@ -321,6 +319,7 @@ Tcl_UtfToUniChar(src, chPtr) *chPtr = (Tcl_UniChar) (((byte & 0x1F) << 6) | (src[1] & 0x3F)); return 2; } + /* * A two-byte-character lead-byte not followed by trail-byte * represents itself. @@ -338,6 +337,7 @@ Tcl_UtfToUniChar(src, chPtr) | ((src[1] & 0x3F) << 6) | (src[2] & 0x3F)); return 3; } + /* * A three-byte-character lead-byte not followed by two trail-bytes * represents itself. @@ -383,9 +383,8 @@ Tcl_UtfToUniChar(src, chPtr) * * Results: * The return value is a pointer to the Unicode representation of the - * UTF-8 string. Storage for the return value is appended to the - * end of dsPtr. The Unicode string is terminated with a Unicode - * NULL character. + * UTF-8 string. Storage for the return value is appended to the end of + * dsPtr. The Unicode string is terminated with a Unicode NULL character. * * Side effects: * None. @@ -396,8 +395,8 @@ Tcl_UtfToUniChar(src, chPtr) Tcl_UniChar * Tcl_UtfToUniCharDString(src, length, dsPtr) CONST char *src; /* UTF-8 string to convert to Unicode. */ - int length; /* Length of UTF-8 string in bytes, or -1 - * for strlen(). */ + int length; /* Length of UTF-8 string in bytes, or -1 for + * strlen(). */ Tcl_DString *dsPtr; /* Unicode representation of string is * appended to this previously initialized * DString. */ @@ -411,8 +410,8 @@ Tcl_UtfToUniCharDString(src, length, dsPtr) } /* - * Unicode string length in Tcl_UniChars will be <= UTF-8 string length - * in bytes. + * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in + * bytes. */ oldLength = Tcl_DStringLength(dsPtr); @@ -438,9 +437,9 @@ Tcl_UtfToUniCharDString(src, length, dsPtr) * * Tcl_UtfCharComplete -- * - * Determine if the UTF-8 string of the given length is long enough - * to be decoded by Tcl_UtfToUniChar(). This does not ensure that the - * UTF-8 string is properly formed. Equivalent to Plan 9 fullrune(). + * Determine if the UTF-8 string of the given length is long enough to be + * decoded by Tcl_UtfToUniChar(). This does not ensure that the UTF-8 + * string is properly formed. Equivalent to Plan 9 fullrune(). * * Results: * The return value is 0 if the string is not long enough, non-zero @@ -454,8 +453,8 @@ Tcl_UtfToUniCharDString(src, length, dsPtr) int Tcl_UtfCharComplete(src, length) - CONST char *src; /* String to check if first few bytes - * contain a complete UTF-8 character. */ + CONST char *src; /* String to check if first few bytes contain + * a complete UTF-8 character. */ int length; /* Length of above string in bytes. */ { int ch; @@ -469,9 +468,9 @@ Tcl_UtfCharComplete(src, length) * * Tcl_NumUtfChars -- * - * Returns the number of characters (not bytes) in the UTF-8 string, - * not including the terminating NULL byte. This is equivalent to - * Plan 9 utflen() and utfnlen(). + * Returns the number of characters (not bytes) in the UTF-8 string, not + * including the terminating NULL byte. This is equivalent to Plan 9 + * utflen() and utfnlen(). * * Results: * As above. @@ -495,8 +494,8 @@ Tcl_NumUtfChars(src, length) /* * The separate implementations are faster. * - * Since this is a time-sensitive function, we also do the check for - * the single-byte char case specially. + * Since this is a time-sensitive function, we also do the check for the + * single-byte char case specially. */ i = 0; @@ -528,14 +527,13 @@ Tcl_NumUtfChars(src, length) * * Tcl_UtfFindFirst -- * - * Returns a pointer to the first occurance of the given Tcl_UniChar - * in the NULL-terminated UTF-8 string. The NULL terminator is - * considered part of the UTF-8 string. Equivalent to Plan 9 - * utfrune(). + * Returns a pointer to the first occurance of the given Tcl_UniChar in + * the NULL-terminated UTF-8 string. The NULL terminator is considered + * part of the UTF-8 string. Equivalent to Plan 9 utfrune(). * * Results: - * As above. If the Tcl_UniChar does not exist in the given string, - * the return value is NULL. + * As above. If the Tcl_UniChar does not exist in the given string, the + * return value is NULL. * * Side effects: * None. @@ -567,14 +565,13 @@ Tcl_UtfFindFirst(src, ch) * * Tcl_UtfFindLast -- * - * Returns a pointer to the last occurance of the given Tcl_UniChar - * in the NULL-terminated UTF-8 string. The NULL terminator is - * considered part of the UTF-8 string. Equivalent to Plan 9 - * utfrrune(). + * Returns a pointer to the last occurance of the given Tcl_UniChar in + * the NULL-terminated UTF-8 string. The NULL terminator is considered + * part of the UTF-8 string. Equivalent to Plan 9 utfrrune(). * * Results: - * As above. If the Tcl_UniChar does not exist in the given string, - * the return value is NULL. + * As above. If the Tcl_UniChar does not exist in the given string, the + * return value is NULL. * * Side effects: * None. @@ -610,14 +607,13 @@ Tcl_UtfFindLast(src, ch) * * Tcl_UtfNext -- * - * Given a pointer to some current location in a UTF-8 string, - * move forward one character. The caller must ensure that they - * are not asking for the next character after the last character - * in the string. + * Given a pointer to some current location in a UTF-8 string, move + * forward one character. The caller must ensure that they are not asking + * for the next character after the last character in the string. * * Results: - * The return value is the pointer to the next character in - * the UTF-8 string. + * The return value is the pointer to the next character in the UTF-8 + * string. * * Side effects: * None. @@ -639,15 +635,15 @@ Tcl_UtfNext(src) * * Tcl_UtfPrev -- * - * Given a pointer to some current location in a UTF-8 string, - * move backwards one character. This works correctly when the - * pointer is in the middle of a UTF-8 character. + * Given a pointer to some current location in a UTF-8 string, move + * backwards one character. This works correctly when the pointer is in + * the middle of a UTF-8 character. * * Results: - * The return value is a pointer to the previous character in the - * UTF-8 string. If the current location was already at the - * beginning of the string, the return value will also be a - * pointer to the beginning of the string. + * The return value is a pointer to the previous character in the UTF-8 + * string. If the current location was already at the beginning of the + * string, the return value will also be a pointer to the beginning of + * the string. * * Side effects: * None. @@ -657,10 +653,9 @@ Tcl_UtfNext(src) CONST char * Tcl_UtfPrev(src, start) - CONST char *src; /* The current location in the string. */ - CONST char *start; /* Pointer to the beginning of the - * string, to avoid going backwards too - * far. */ + CONST char *src; /* The current location in the string. */ + CONST char *start; /* Pointer to the beginning of the string, to + * avoid going backwards too far. */ { CONST char *look; int i, byte; @@ -691,8 +686,8 @@ Tcl_UtfPrev(src, start) * * Tcl_UniCharAtIndex -- * - * Returns the Unicode character represented at the specified - * character (not byte) position in the UTF-8 string. + * Returns the Unicode character represented at the specified character + * (not byte) position in the UTF-8 string. * * Results: * As above. @@ -722,8 +717,8 @@ Tcl_UniCharAtIndex(src, index) * * Tcl_UtfAtIndex -- * - * Returns a pointer to the specified character (not byte) position - * in the UTF-8 string. + * Returns a pointer to the specified character (not byte) position in + * the UTF-8 string. * * Results: * As above. @@ -757,30 +752,29 @@ Tcl_UtfAtIndex(src, index) * * Results: * Stores the bytes represented by the backslash sequence in dst and - * returns the number of bytes written to dst. At most TCL_UTF_MAX - * bytes are written to dst; dst must have been large enough to accept - * those bytes. If readPtr isn't NULL then it is filled in with a - * count of the number of bytes in the backslash sequence. + * returns the number of bytes written to dst. At most TCL_UTF_MAX bytes + * are written to dst; dst must have been large enough to accept those + * bytes. If readPtr isn't NULL then it is filled in with a count of the + * number of bytes in the backslash sequence. * * Side effects: - * The maximum number of bytes it takes to represent a Unicode - * character in UTF-8 is guaranteed to be less than the number of - * bytes used to express the backslash sequence that represents - * that Unicode character. If the target buffer into which the - * caller is going to store the bytes that represent the Unicode - * character is at least as large as the source buffer from which - * the backslashed sequence was extracted, no buffer overruns should - * occur. + * The maximum number of bytes it takes to represent a Unicode character + * in UTF-8 is guaranteed to be less than the number of bytes used to + * express the backslash sequence that represents that Unicode character. + * If the target buffer into which the caller is going to store the bytes + * that represent the Unicode character is at least as large as the + * source buffer from which the backslashed sequence was extracted, no + * buffer overruns should occur. * *--------------------------------------------------------------------------- */ int Tcl_UtfBackslash(src, readPtr, dst) - CONST char *src; /* Points to the backslash character of - * a backslash sequence. */ - int *readPtr; /* Fill in with number of characters read - * from src, unless NULL. */ + CONST char *src; /* Points to the backslash character of a + * backslash sequence. */ + int *readPtr; /* Fill in with number of characters read from + * src, unless NULL. */ char *dst; /* Filled with the bytes represented by the * backslash sequence. */ { @@ -804,12 +798,12 @@ Tcl_UtfBackslash(src, readPtr, dst) * * Tcl_UtfToUpper -- * - * Convert lowercase characters to uppercase characters in a UTF - * string in place. The conversion may shrink the UTF string. + * Convert lowercase characters to uppercase characters in a UTF string + * in place. The conversion may shrink the UTF string. * * Results: - * Returns the number of bytes in the resulting string - * excluding the trailing null. + * Returns the number of bytes in the resulting string excluding the + * trailing null. * * Side effects: * Writes a terminating null after the last converted character. @@ -831,13 +825,13 @@ Tcl_UtfToUpper(str) src = dst = str; while (*src) { - bytes = TclUtfToUniChar(src, &ch); + bytes = TclUtfToUniChar(src, &ch); upChar = Tcl_UniCharToUpper(ch); /* - * To keep badly formed Utf strings from getting inflated by - * the conversion (thereby causing a segfault), only copy the - * upper case char to dst if its size is <= the original char. + * To keep badly formed Utf strings from getting inflated by the + * conversion (thereby causing a segfault), only copy the upper case + * char to dst if its size is <= the original char. */ if (bytes < UtfCount(upChar)) { @@ -857,12 +851,12 @@ Tcl_UtfToUpper(str) * * Tcl_UtfToLower -- * - * Convert uppercase characters to lowercase characters in a UTF - * string in place. The conversion may shrink the UTF string. + * Convert uppercase characters to lowercase characters in a UTF string + * in place. The conversion may shrink the UTF string. * * Results: - * Returns the number of bytes in the resulting string - * excluding the trailing null. + * Returns the number of bytes in the resulting string excluding the + * trailing null. * * Side effects: * Writes a terminating null after the last converted character. @@ -888,9 +882,9 @@ Tcl_UtfToLower(str) lowChar = Tcl_UniCharToLower(ch); /* - * To keep badly formed Utf strings from getting inflated by - * the conversion (thereby causing a segfault), only copy the - * lower case char to dst if its size is <= the original char. + * To keep badly formed Utf strings from getting inflated by the + * conversion (thereby causing a segfault), only copy the lower case + * char to dst if its size is <= the original char. */ if (bytes < UtfCount(lowChar)) { @@ -910,13 +904,13 @@ Tcl_UtfToLower(str) * * Tcl_UtfToTitle -- * - * Changes the first character of a UTF string to title case or - * uppercase and the rest of the string to lowercase. The - * conversion happens in place and may shrink the UTF string. + * Changes the first character of a UTF string to title case or uppercase + * and the rest of the string to lowercase. The conversion happens in + * place and may shrink the UTF string. * * Results: - * Returns the number of bytes in the resulting string - * excluding the trailing null. + * Returns the number of bytes in the resulting string excluding the + * trailing null. * * Side effects: * Writes a terminating null after the last converted character. @@ -972,8 +966,8 @@ Tcl_UtfToTitle(str) * * TclpUtfNcmp2 -- * - * Compare at most n bytes of utf-8 strings cs and ct. Both cs - * and ct are assumed to be at least n bytes long. + * Compare at most n bytes of utf-8 strings cs and ct. Both cs and ct are + * assumed to be at least n bytes long. * * Results: * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. @@ -991,10 +985,11 @@ TclpUtfNcmp2(cs, ct, n) unsigned long n; /* Number of *bytes* to compare. */ { /* - * We can't simply call 'memcmp(cs, ct, n);' because we need to check - * for Tcl's \xC0\x80 non-utf-8 null encoding. - * Otherwise utf-8 lexes fine in the strcmp manner. + * We can't simply call 'memcmp(cs, ct, n);' because we need to check for + * Tcl's \xC0\x80 non-utf-8 null encoding. Otherwise utf-8 lexes fine in + * the strcmp manner. */ + register int result = 0; for ( ; n != 0; n--, cs++, ct++) { @@ -1005,6 +1000,7 @@ TclpUtfNcmp2(cs, ct, n) } if (n && ((UCHAR(*cs) == 0xC0) || (UCHAR(*ct) == 0xC0))) { unsigned char c1, c2; + c1 = ((UCHAR(*cs) == 0xC0) && (UCHAR(cs[1]) == 0x80)) ? 0 : UCHAR(*cs); c2 = ((UCHAR(*ct) == 0xC0) && (UCHAR(ct[1]) == 0x80)) ? 0 : UCHAR(*ct); result = (c1 - c2); @@ -1017,8 +1013,8 @@ TclpUtfNcmp2(cs, ct, n) * * Tcl_UtfNcmp -- * - * Compare at most numChars UTF chars of string cs to string ct. - * Both cs and ct are assumed to be at least numChars UTF chars long. + * Compare at most numChars UTF chars of string cs to string ct. Both cs + * and ct are assumed to be at least numChars UTF chars long. * * Results: * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. @@ -1036,17 +1032,20 @@ Tcl_UtfNcmp(cs, ct, numChars) unsigned long numChars; /* Number of UTF chars to compare. */ { Tcl_UniChar ch1, ch2; + /* - * Cannot use 'memcmp(cs, ct, n);' as byte representation of - * \u0000 (the pair of bytes 0xc0,0x80) is larger than byte - * representation of \u0001 (the byte 0x01.) + * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the + * pair of bytes 0xc0,0x80) is larger than byte representation of \u0001 + * (the byte 0x01.) */ + while (numChars-- > 0) { /* - * n must be interpreted as chars, not bytes. - * This should be called only when both strings are of - * at least n chars long (no need for \0 check) + * n must be interpreted as chars, not bytes. This should be called + * only when both strings are of at least n chars long (no need for \0 + * check) */ + cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { @@ -1251,12 +1250,14 @@ Tcl_UniCharNcmp(ucs, uct, numChars) /* * We are definitely on a big-endian machine; memcmp() is safe */ + return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar)); #else /* !WORDS_BIGENDIAN */ /* * We can't simply call memcmp() because that is not lexically correct. */ + for ( ; numChars != 0; ucs++, uct++, numChars--) { if (*ucs != *uct) { return (*ucs - *uct); @@ -1556,8 +1557,7 @@ Tcl_UniCharIsUpper(ch) * * Tcl_UniCharIsWordChar -- * - * Test if a character is alphanumeric or a connector punctuation - * mark. + * Test if a character is alphanumeric or a connector punctuation mark. * * Results: * Returns 1 if character is a word character. @@ -1583,17 +1583,16 @@ Tcl_UniCharIsWordChar(ch) * Tcl_UniCharCaseMatch -- * * See if a particular Unicode string matches a particular pattern. - * Allows case insensitivity. This is the Unicode equivalent of - * the char* Tcl_StringCaseMatch. The UniChar strings must be - * NULL-terminated. This has no provision for counted UniChar - * strings, thus should not be used where NULLs are expected in the - * UniChar string. Use TclUniCharMatch where possible. + * Allows case insensitivity. This is the Unicode equivalent of the char* + * Tcl_StringCaseMatch. The UniChar strings must be NULL-terminated. + * This has no provision for counted UniChar strings, thus should not be + * used where NULLs are expected in the UniChar string. Use + * TclUniCharMatch where possible. * * Results: - * The return value is 1 if string matches pattern, and - * 0 otherwise. The matching operation permits the following - * special characters in the pattern: *?\[] (see the manual - * entry for details on what these mean). + * The return value is 1 if string matches pattern, and 0 otherwise. The + * matching operation permits the following special characters in the + * pattern: *?\[] (see the manual entry for details on what these mean). * * Side effects: * None. @@ -1603,9 +1602,10 @@ Tcl_UniCharIsWordChar(ch) int Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase) - CONST Tcl_UniChar *uniStr; /* Unicode String. */ - CONST Tcl_UniChar *uniPattern; /* Pattern, which may contain special - * characters. */ + CONST Tcl_UniChar *uniStr; /* Unicode String. */ + CONST Tcl_UniChar *uniPattern; + /* Pattern, which may contain special + * characters. */ int nocase; /* 0 for case sensitive, 1 for insensitive */ { Tcl_UniChar ch1, p; @@ -1614,9 +1614,9 @@ Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase) p = *uniPattern; /* - * See if we're at the end of both the pattern and the string. If - * so, we succeeded. If we're at the end of the pattern but not at - * the end of the string, we failed. + * See if we're at the end of both the pattern and the string. If so, + * we succeeded. If we're at the end of the pattern but not at the end + * of the string, we failed. */ if (p == 0) { @@ -1627,8 +1627,8 @@ Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase) } /* - * Check for a "*" as the next pattern character. It matches any - * substring. We handle this by skipping all the characters up to the + * Check for a "*" as the next pattern character. It matches any + * substring. We handle this by skipping all the characters up to the * next matching one in the pattern, and then calling ourselves * recursively for each postfix of string, until either we match or we * reach the end of the string. @@ -1638,7 +1638,10 @@ Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase) /* * Skip all successive *'s in the pattern */ - while (*(++uniPattern) == '*') {} + + while (*(++uniPattern) == '*') { + /* empty body */ + } p = *uniPattern; if (p == 0) { return 1; @@ -1652,6 +1655,7 @@ Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase) * quickly if the next char in the pattern isn't a special * character */ + if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while (*uniStr && (p != *uniStr) @@ -1659,7 +1663,9 @@ Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase) uniStr++; } } else { - while (*uniStr && (p != *uniStr)) { uniStr++; } + while (*uniStr && (p != *uniStr)) { + uniStr++; + } } } if (Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase)) { @@ -1673,8 +1679,8 @@ Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase) } /* - * Check for a "?" as the next pattern character. It matches - * any single character. + * Check for a "?" as the next pattern character. It matches any + * single character. */ if (p == '?') { @@ -1684,9 +1690,9 @@ Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase) } /* - * Check for a "[" as the next pattern character. It is followed - * by a list of characters that are acceptable, or by a range - * (two characters separated by "-"). + * Check for a "[" as the next pattern character. It is followed by a + * list of characters that are acceptable, or by a range (two + * characters separated by "-"). */ if (p == '[') { @@ -1699,7 +1705,8 @@ Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase) if ((*uniPattern == ']') || (*uniPattern == 0)) { return 0; } - startChar = (nocase ? Tcl_UniCharToLower(*uniPattern) : *uniPattern); + startChar = (nocase ? Tcl_UniCharToLower(*uniPattern) + : *uniPattern); uniPattern++; if (*uniPattern == '-') { uniPattern++; @@ -1732,8 +1739,8 @@ Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase) } /* - * If the next pattern character is '\', just strip off the '\' - * so we do exact matching on the character that follows. + * If the next pattern character is '\', just strip off the '\' so we + * do exact matching on the character that follows. */ if (p == '\\') { @@ -1743,12 +1750,13 @@ Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase) } /* - * There's no special character. Just make sure that the next - * bytes of each string match. + * There's no special character. Just make sure that the next bytes + * of each string match. */ if (nocase) { - if (Tcl_UniCharToLower(*uniStr) != Tcl_UniCharToLower(*uniPattern)) { + if (Tcl_UniCharToLower(*uniStr) != + Tcl_UniCharToLower(*uniPattern)) { return 0; } } else if (*uniStr != *uniPattern) { @@ -1765,15 +1773,14 @@ Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase) * TclUniCharMatch -- * * See if a particular Unicode string matches a particular pattern. - * Allows case insensitivity. This is the Unicode equivalent of the - * char* Tcl_StringCaseMatch. This variant of Tcl_UniCharCaseMatch - * uses counted Strings, so embedded NULLs are allowed. + * Allows case insensitivity. This is the Unicode equivalent of the char* + * Tcl_StringCaseMatch. This variant of Tcl_UniCharCaseMatch uses counted + * Strings, so embedded NULLs are allowed. * * Results: - * The return value is 1 if string matches pattern, and - * 0 otherwise. The matching operation permits the following - * special characters in the pattern: *?\[] (see the manual - * entry for details on what these mean). + * The return value is 1 if string matches pattern, and 0 otherwise. The + * matching operation permits the following special characters in the + * pattern: *?\[] (see the manual entry for details on what these mean). * * Side effects: * None. @@ -1793,14 +1800,14 @@ TclUniCharMatch(string, strLen, pattern, ptnLen, nocase) CONST Tcl_UniChar *stringEnd, *patternEnd; Tcl_UniChar p; - stringEnd = string + strLen; + stringEnd = string + strLen; patternEnd = pattern + ptnLen; while (1) { /* - * See if we're at the end of both the pattern and the string. If - * so, we succeeded. If we're at the end of the pattern but not at - * the end of the string, we failed. + * See if we're at the end of both the pattern and the string. If so, + * we succeeded. If we're at the end of the pattern but not at the end + * of the string, we failed. */ if (pattern == patternEnd) { @@ -1812,8 +1819,8 @@ TclUniCharMatch(string, strLen, pattern, ptnLen, nocase) } /* - * Check for a "*" as the next pattern character. It matches any - * substring. We handle this by skipping all the characters up to the + * Check for a "*" as the next pattern character. It matches any + * substring. We handle this by skipping all the characters up to the * next matching one in the pattern, and then calling ourselves * recursively for each postfix of string, until either we match or we * reach the end of the string. @@ -1821,9 +1828,12 @@ TclUniCharMatch(string, strLen, pattern, ptnLen, nocase) if (p == '*') { /* - * Skip all successive *'s in the pattern + * Skip all successive *'s in the pattern. */ - while (*(++pattern) == '*') {} + + while (*(++pattern) == '*') { + /* empty body */ + } if (pattern == patternEnd) { return 1; } @@ -1835,8 +1845,9 @@ TclUniCharMatch(string, strLen, pattern, ptnLen, nocase) /* * Optimization for matching - cruise through the string * quickly if the next char in the pattern isn't a special - * character + * character. */ + if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while ((string < stringEnd) && (p != *string) @@ -1861,8 +1872,8 @@ TclUniCharMatch(string, strLen, pattern, ptnLen, nocase) } /* - * Check for a "?" as the next pattern character. It matches - * any single character. + * Check for a "?" as the next pattern character. It matches any + * single character. */ if (p == '?') { @@ -1872,9 +1883,9 @@ TclUniCharMatch(string, strLen, pattern, ptnLen, nocase) } /* - * Check for a "[" as the next pattern character. It is followed - * by a list of characters that are acceptable, or by a range - * (two characters separated by "-"). + * Check for a "[" as the next pattern character. It is followed by a + * list of characters that are acceptable, or by a range (two + * characters separated by "-"). */ if (p == '[') { @@ -1920,8 +1931,8 @@ TclUniCharMatch(string, strLen, pattern, ptnLen, nocase) } /* - * If the next pattern character is '\', just strip off the '\' - * so we do exact matching on the character that follows. + * If the next pattern character is '\', just strip off the '\' so we + * do exact matching on the character that follows. */ if (p == '\\') { @@ -1931,8 +1942,8 @@ TclUniCharMatch(string, strLen, pattern, ptnLen, nocase) } /* - * There's no special character. Just make sure that the next - * bytes of each string match. + * There's no special character. Just make sure that the next bytes of + * each string match. */ if (nocase) { @@ -1946,3 +1957,11 @@ TclUniCharMatch(string, strLen, pattern, ptnLen, nocase) pattern++; } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |