summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2005-07-21 14:38:31 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2005-07-21 14:38:31 (GMT)
commitbe7cd35abf2f4421f8c0c70780675e4313589df3 (patch)
treef4e1f849d58fbb34a2a00e11e8f3286b0d65cf09 /generic
parent04b1bffa1cc7b07cafdb83dd3f39c271f6493f7b (diff)
downloadtcl-be7cd35abf2f4421f8c0c70780675e4313589df3.zip
tcl-be7cd35abf2f4421f8c0c70780675e4313589df3.tar.gz
tcl-be7cd35abf2f4421f8c0c70780675e4313589df3.tar.bz2
Systematizing the formatting
Diffstat (limited to 'generic')
-rw-r--r--generic/tclEnv.c342
-rw-r--r--generic/tclHash.c249
-rw-r--r--generic/tclIndexObj.c371
-rw-r--r--generic/tclMain.c369
-rw-r--r--generic/tclNotify.c511
-rw-r--r--generic/tclParse.c1677
-rw-r--r--generic/tclParseExpr.c1103
-rw-r--r--generic/tclPathObj.c1813
-rw-r--r--generic/tclPipe.c413
-rw-r--r--generic/tclPkgConfig.c149
-rw-r--r--generic/tclProc.c567
-rw-r--r--generic/tclRegexp.c284
-rw-r--r--generic/tclScan.c971
-rw-r--r--generic/tclThread.c116
-rw-r--r--generic/tclUtf.c415
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:
+ */