From e0ef1543276028c3f855c5e12b53551fc20fdebf Mon Sep 17 00:00:00 2001 From: stanton Date: Wed, 3 Feb 1999 00:55:04 +0000 Subject: * generic/tclProc.c: * generic/tclNamesp.c: * generic/tclInt.h: * generic/tclCmdIL.c: * generic/tclBasic.c: * generic/tclVar.c: Applied patch from Viktor Dukhovni to rationalize TCL_LEAVE_ERR_MSG behavior when creating variables. * generic/tclVar.c: Fixed bug in namespace tail computation. Fixed bug where upvar could resurrect a namespace variable whose namespace had been deleted. * generic/tclCompile.c (TclCompileExprCmd): Eliminated yet another bogus optimization in expression compilation. * generic/tclCompile.c (CompileExprWord): Fixed exception stack overflow bug caused by missing statement. [Bug: 928] * generic/tclIOCmd.c: * generic/tclBasic.c: Objectified the "open" command. [Bug: 1113] --- generic/tclBasic.c | 31 +++--- generic/tclCmdIL.c | 24 ++--- generic/tclCompile.c | 6 +- generic/tclInt.h | 6 +- generic/tclNamesp.c | 137 +++++++++----------------- generic/tclProc.c | 12 +-- generic/tclTest.c | 60 ++++++------ generic/tclVar.c | 268 ++++++++++++++++++++++++++++----------------------- tests/var.test | 194 +++++++++++++++++++++++++++++-------- 9 files changed, 407 insertions(+), 331 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 1d66c80..70c437e 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7,12 +7,12 @@ * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998 by Scriptics Corporation. + * 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. * - * RCS: @(#) $Id: tclBasic.c,v 1.14 1999/02/02 22:25:42 stanton Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.15 1999/02/03 00:55:04 stanton Exp $ */ #include "tclInt.h" @@ -1421,7 +1421,7 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) Command *cmdPtr, *refCmdPtr; Tcl_HashEntry *hPtr; char *tail; - int new, result; + int new; ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { @@ -1440,10 +1440,9 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) */ if (strstr(cmdName, "::") != NULL) { - result = TclGetNamespaceForQualName(interp, cmdName, - (Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr, - &dummy1, &dummy2, &tail); - if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) { + TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, + CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { return (Tcl_Command) NULL; } } else { @@ -1568,7 +1567,7 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) Command *cmdPtr, *refCmdPtr; Tcl_HashEntry *hPtr; char *tail; - int new, result; + int new; ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { @@ -1587,10 +1586,9 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) */ if (strstr(cmdName, "::") != NULL) { - result = TclGetNamespaceForQualName(interp, cmdName, - (Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr, - &dummy1, &dummy2, &tail); - if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) { + TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, + CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { return (Tcl_Command) NULL; } } else { @@ -1921,12 +1919,9 @@ TclRenameCommand(interp, oldName, newName) * Tcl_CreateCommand would. */ - result = TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL, - (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), - &newNsPtr, &dummy1, &dummy2, &newTail); - if (result != TCL_OK) { - return result; - } + TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL, + CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); + if ((newNsPtr == NULL) || (newTail == NULL)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't rename to \"", newName, "\": bad command name", diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 3738b64..25b563b 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -9,12 +9,12 @@ * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998 by Scriptics Corporation. + * 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. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.10 1998/10/13 20:30:22 rjohnson Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.11 1999/02/03 00:55:04 stanton Exp $ */ #include "tclInt.h" @@ -643,7 +643,6 @@ InfoCommandsCmd(dummy, interp, objc, objv) Tcl_Obj *listPtr, *elemObjPtr; int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ Tcl_Command cmd; - int result; /* * Get the pattern and find the "effective namespace" in which to @@ -666,12 +665,9 @@ InfoCommandsCmd(dummy, interp, objc, objv) Namespace *dummy1NsPtr, *dummy2NsPtr; pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); - result = TclGetNamespaceForQualName(interp, pattern, - (Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG, - &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); - if (result != TCL_OK) { - return TCL_ERROR; - } + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, + /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + if (nsPtr != NULL) { /* we successfully found the pattern's ns */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } @@ -1628,7 +1624,6 @@ InfoVarsCmd(dummy, interp, objc, objv) Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_Obj *listPtr, *elemObjPtr; int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ - int result; /* * Get the pattern and find the "effective namespace" in which to @@ -1652,12 +1647,9 @@ InfoVarsCmd(dummy, interp, objc, objv) Namespace *dummy1NsPtr, *dummy2NsPtr; pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); - result = TclGetNamespaceForQualName(interp, pattern, - (Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG, - &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); - if (result != TCL_OK) { - return TCL_ERROR; - } + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, + /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + if (nsPtr != NULL) { /* we successfully found the pattern's ns */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 3c67280..15a30a7 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.12 1999/02/02 22:26:11 stanton Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.13 1999/02/03 00:55:04 stanton Exp $ */ #include "tclInt.h" @@ -3879,7 +3879,7 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr) /* * Scan the concatenated expression's characters looking for any - * '['s or (for now) '\'s. If any are found, just call the expr cmd + * '['s or '\'s or '$'s. If any are found, just call the expr cmd * at runtime. */ @@ -3888,7 +3888,7 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr) last = first + (Tcl_DStringLength(&buffer) - 1); for (p = first; p <= last; p++) { c = *p; - if ((c == '[') || (c == '\\')) { + if ((c == '[') || (c == '\\') || (c == '$')) { inlineCode = 0; break; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 61b006b..50e973d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -6,12 +6,12 @@ * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1993-1997 Lucent Technologies. - * Copyright (c) 1998 by Scriptics Corporation. + * 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. * - * RCS: @(#) $Id: tclInt.h,v 1.21 1999/02/02 22:27:02 stanton Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.22 1999/02/03 00:55:05 stanton Exp $ */ #ifndef _TCLINT @@ -1502,7 +1502,7 @@ EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp *interp, char *string, long *longPtr)); EXTERN int TclGetLoadedPackages _ANSI_ARGS_(( Tcl_Interp *interp, char *targetName)); -EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_(( +EXTERN void TclGetNamespaceForQualName _ANSI_ARGS_(( Tcl_Interp *interp, char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 52dfcc3..cc3469d 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -9,7 +9,7 @@ * * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1997 Sun Microsystems, Inc. - * Copyright (c) 1998 by Scriptics Corporation. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * Originally implemented by * Michael J. McLennan @@ -19,7 +19,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.8 1998/09/14 18:40:01 stanton Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.9 1999/02/03 00:55:05 stanton Exp $ */ #include "tclInt.h" @@ -298,11 +298,8 @@ Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame) } else { nsPtr = (Namespace *) namespacePtr; if (nsPtr->flags & NS_DEAD) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "namespace \"", - nsPtr->fullName, "\" not found in context \"", - Tcl_GetCurrentNamespace(interp)->fullName, "\"", - (char *) NULL); - return TCL_ERROR; + panic("Trying to push call frame for dead namespace"); + /*NOTREACHED*/ } } @@ -458,7 +455,7 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) char *simpleName; Tcl_HashEntry *entryPtr; Tcl_DString buffer1, buffer2; - int newEntry, result; + int newEntry; /* * If there is no active namespace, the interpreter is being @@ -482,13 +479,9 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) * Find the parent for the new namespace. */ - result = TclGetNamespaceForQualName(interp, name, - (Namespace *) NULL, - /*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), - &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); - if (result != TCL_OK) { - return NULL; - } + TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, + /*flags*/ CREATE_NS_IF_UNKNOWN, &parentPtr, &dummy1Ptr, + &dummy2Ptr, &simpleName); /* * If the unqualified name at the end is empty, there were trailing @@ -926,7 +919,7 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) Namespace *nsPtr, *exportNsPtr, *dummyPtr; Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); char *simplePattern, *patternCpy; - int neededElems, len, i, result; + int neededElems, len, i; /* * If the specified namespace is NULL, use the current namespace. @@ -959,12 +952,9 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) * Check that the pattern doesn't have namespace qualifiers. */ - result = TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ TCL_LEAVE_ERR_MSG, &exportNsPtr, &dummyPtr, - &dummyPtr, &simplePattern); - if (result != TCL_OK) { - return result; - } + TclGetNamespaceForQualName(interp, pattern, nsPtr, + /*flags*/ 0, &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); + if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid export pattern \"", pattern, @@ -1174,12 +1164,9 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) "empty import pattern", -1); return TCL_ERROR; } - result = TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr, - &dummyPtr, &simplePattern); - if (result != TCL_OK) { - return TCL_ERROR; - } + TclGetNamespaceForQualName(interp, pattern, nsPtr, + /*flags*/ 0, &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); + if (importNsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown namespace in import pattern \"", @@ -1322,7 +1309,6 @@ Tcl_ForgetImport(interp, namespacePtr, pattern) register Tcl_HashEntry *hPtr; Tcl_HashSearch search; Command *cmdPtr; - int result; /* * If the specified namespace is NULL, use the current namespace. @@ -1340,12 +1326,9 @@ Tcl_ForgetImport(interp, namespacePtr, pattern) * the end. */ - result = TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr, - &actualCtxPtr, &simplePattern); - if (result != TCL_OK) { - return result; - } + TclGetNamespaceForQualName(interp, pattern, nsPtr, + /*flags*/ 0, &importNsPtr, &dummyPtr, &actualCtxPtr, &simplePattern); + if (importNsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown namespace in namespace forget pattern \"", @@ -1557,34 +1540,28 @@ DeleteImportedCmd(clientData) * final component is stored in *simpleNamePtr. * * Results: - * Ordinarily this procedure returns TCL_OK. It sets *nsPtrPtr and - * *altNsPtrPtr to point to the two possible namespaces which represent - * the last (containing) namespace in the qualified name. If the - * procedure sets either *nsPtrPtr or *altNsPtrPtr to NULL, then the - * search along that path failed. The procedure also stores a pointer - * to the simple name of the final component in *simpleNamePtr. If the - * qualified name is "::" or was treated as a namespace reference - * (FIND_ONLY_NS), the procedure stores a pointer to the - * namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets + * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible + * namespaces which represent the last (containing) namespace in the + * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr + * to NULL, then the search along that path failed. The procedure also + * stores a pointer to the simple name of the final component in + * *simpleNamePtr. If the qualified name is "::" or was treated as a + * namespace reference (FIND_ONLY_NS), the procedure stores a pointer + * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets * *simpleNamePtr to point to an empty string. * - * If there is an error, this procedure returns TCL_ERROR. If "flags" - * contains TCL_LEAVE_ERR_MSG, an error message is returned in the - * interpreter's result object. Otherwise, the interpreter's result - * object is left unchanged. - * * *actualCxtPtrPtr is set to the actual context namespace. It is * set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr * is NULL, it is set to the current namespace context. * * Side effects: - * If flags contains TCL_LEAVE_ERR_MSG and an error is encountered, - * the interpreter's result object will contain an error message. + * If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be + * created. * *---------------------------------------------------------------------- */ -int +void TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) Tcl_Interp *interp; /* Interpreter in which to find the @@ -1634,7 +1611,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, char *nsName; Tcl_HashEntry *entryPtr; Tcl_DString buffer; - int len, result; + int len; /* * Determine the context namespace nsPtr in which to start the primary @@ -1670,7 +1647,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, *altNsPtrPtr = NULL; *actualCxtPtrPtr = globalNsPtr; *simpleNamePtr = start; /* points to empty string */ - return TCL_OK; + return; } } *actualCxtPtrPtr = nsPtr; @@ -1729,7 +1706,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, *altNsPtrPtr = altNsPtr; *simpleNamePtr = start; Tcl_DStringFree(&buffer); - return TCL_OK; + return; } } else { /* @@ -1759,18 +1736,15 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, } else if (flags & CREATE_NS_IF_UNKNOWN) { Tcl_CallFrame frame; - result = Tcl_PushCallFrame(interp, &frame, + (void) Tcl_PushCallFrame(interp, &frame, (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); - if (result != TCL_OK) { - Tcl_DStringFree(&buffer); - return result; - } + nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); Tcl_PopCallFrame(interp); + if (nsPtr == NULL) { - Tcl_DStringFree(&buffer); - return TCL_ERROR; + panic("Could not create namespace '%s'", nsName); } } else { /* namespace not found and wasn't created */ nsPtr = NULL; @@ -1799,7 +1773,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, *altNsPtrPtr = NULL; *simpleNamePtr = NULL; Tcl_DStringFree(&buffer); - return TCL_OK; + return; } start = end; @@ -1832,7 +1806,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, *nsPtrPtr = nsPtr; *altNsPtrPtr = altNsPtr; Tcl_DStringFree(&buffer); - return TCL_OK; + return; } /* @@ -1873,7 +1847,6 @@ Tcl_FindNamespace(interp, name, contextNsPtr, flags) { Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; char *dummy; - int result; /* * Find the namespace(s) that contain the specified namespace name. @@ -1881,12 +1854,9 @@ Tcl_FindNamespace(interp, name, contextNsPtr, flags) * to its last component, a namespace. */ - result = TclGetNamespaceForQualName(interp, name, - (Namespace *) contextNsPtr, /*flags*/ (flags | FIND_ONLY_NS), - &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); - if (result != TCL_OK) { - return NULL; - } + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + (flags | FIND_ONLY_NS), &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); + if (nsPtr != NULL) { return (Tcl_Namespace *) nsPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { @@ -1997,12 +1967,8 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags) * Find the namespace(s) that contain the command. */ - result = TclGetNamespaceForQualName(interp, name, - (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], - &cxtNsPtr, &simpleName); - if (result != TCL_OK) { - return (Tcl_Command) NULL; - } + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the command in the command table of its namespace. @@ -2131,12 +2097,8 @@ Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) * Find the namespace(s) that contain the variable. */ - result = TclGetNamespaceForQualName(interp, name, - (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], - &cxtNsPtr, &simpleName); - if (result != TCL_OK) { - return (Tcl_Var) NULL; - } + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the variable in the variable table of its namespace. @@ -3773,7 +3735,6 @@ SetNsNameFromAny(interp, objPtr) char *name, *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; register ResolvedNsName *resNamePtr; - int flags, result; /* * Get the string representation. Make it up-to-date if necessary. @@ -3791,12 +3752,8 @@ SetNsNameFromAny(interp, objPtr) * object with a NULL ResolvedNsName* internal rep. */ - flags = ((interp != NULL)? TCL_LEAVE_ERR_MSG : 0) | FIND_ONLY_NS; - result = TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, - flags, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); - if (result != TCL_OK) { - return result; - } + TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, + /*flags*/ FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); /* * If we found a namespace, then create a new ResolvedNsName structure diff --git a/generic/tclProc.c b/generic/tclProc.c index bb6a8e5..34c6ce6 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -10,7 +10,7 @@ * 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.16 1998/10/05 22:32:10 escoffon Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.17 1999/02/03 00:55:06 stanton Exp $ */ #include "tclInt.h" @@ -70,7 +70,6 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; Tcl_DString ds; - int result; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); @@ -84,12 +83,9 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) */ fullName = Tcl_GetStringFromObj(objv[1], (int *) NULL); - result = TclGetNamespaceForQualName(interp, fullName, - (Namespace *) NULL, TCL_LEAVE_ERR_MSG, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); - if (result != TCL_OK) { - return result; - } + TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL, + /*flags*/ 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + if (nsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't create procedure \"", fullName, diff --git a/generic/tclTest.c b/generic/tclTest.c index 7454771..32b326c 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.6 1998/11/10 06:54:33 jingham Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.7 1999/02/03 00:55:06 stanton Exp $ */ #define TCL_TEST @@ -186,8 +186,8 @@ static int TestPanicCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); -static int TestsetnoerrCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); +static int TestsetCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); static int TestsetobjerrorcodeCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -311,8 +311,10 @@ Tcltest_Init(interp) (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testsetnoerr", TestsetnoerrCmd, + Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testseterr", TestsetCmd, + (ClientData) TCL_LEAVE_ERR_MSG, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testsetobjerrorcode", TestsetobjerrorcodeCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); @@ -2697,51 +2699,47 @@ NoopObjCmd(unused, interp, objc, objv) /* *---------------------------------------------------------------------- * - * TestsetnoerrCmd -- + * TestsetCmd -- * - * Implements the "testsetnoerr" cmd that is used when testing - * the Tcl_Set/GetVar C Api without TCL_LEAVE_ERR_MSG flag + * Implements the "testset{err,noerr}" cmds that are used when testing + * Tcl_Set/GetVar C Api with/without TCL_LEAVE_ERR_MSG flag * * Results: * A standard Tcl result. * * Side effects: - * None. + * Variables may be set. * *---------------------------------------------------------------------- */ /* ARGSUSED */ -static int -TestsetnoerrCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ +TestsetCmd(data, interp, argc, argv) + ClientData data; /* Additional flags for Get/SetVar2. */ register Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { + int flags = (int) data; char *value; + if (argc == 2) { - Tcl_SetResult(interp, "before get", TCL_STATIC); - value = Tcl_GetVar2(interp, argv[1], (char *) NULL, TCL_PARSE_PART1); - if (value == NULL) { - return TCL_ERROR; - } - Tcl_SetResult(interp, value, TCL_VOLATILE); - return TCL_OK; + Tcl_SetResult(interp, "before get", TCL_STATIC); + value = Tcl_GetVar2(interp, argv[1], (char *) NULL, + TCL_PARSE_PART1|flags); + if (value == NULL) { + return TCL_ERROR; + } + Tcl_AppendElement(interp, value); + return TCL_OK; } else if (argc == 3) { - char *m1 = "before set"; - char *message=Tcl_Alloc(strlen(m1)+1); - - strcpy(message,m1); - - Tcl_SetResult(interp, message, TCL_DYNAMIC); - - value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], - TCL_PARSE_PART1); - if (value == NULL) { - return TCL_ERROR; - } - Tcl_SetResult(interp, value, TCL_VOLATILE); + Tcl_SetResult(interp, "before set", TCL_STATIC); + value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], + TCL_PARSE_PART1|flags); + if (value == NULL) { + return TCL_ERROR; + } + Tcl_AppendElement(interp, value); return TCL_OK; } else { Tcl_AppendResult(interp, "wrong # args: should be \"", diff --git a/generic/tclVar.c b/generic/tclVar.c index 88a5354..70efd00 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -9,11 +9,12 @@ * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1997 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. * - * RCS: @(#) $Id: tclVar.c,v 1.6 1998/11/19 20:10:52 stanton Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.7 1999/02/03 00:55:06 stanton Exp $ */ #include "tclInt.h" @@ -28,7 +29,8 @@ static char *noSuchVar = "no such variable"; static char *isArray = "variable is array"; static char *needArray = "variable isn't array"; static char *noSuchElement = "no such element in array"; -static char *danglingUpvar = "upvar refers to element in deleted array"; +static char *danglingElement = "upvar refers to element in deleted array"; +static char *danglingVar = "upvar refers to variable in deleted namespace"; static char *badNamespace = "parent namespace doesn't exist"; static char *missingName = "missing variable name"; @@ -200,7 +202,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, if (cxtNsPtr->varResProc) { result = (*cxtNsPtr->varResProc)(interp, part1, - (Tcl_Namespace *) cxtNsPtr, flags, &var); + (Tcl_Namespace *) cxtNsPtr, flags, &var); } else { result = TCL_CONTINUE; } @@ -208,7 +210,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, while (result == TCL_CONTINUE && resPtr) { if (resPtr->varResProc) { result = (*resPtr->varResProc)(interp, part1, - (Tcl_Namespace *) cxtNsPtr, flags, &var); + (Tcl_Namespace *) cxtNsPtr, flags, &var); } resPtr = resPtr->nextPtr; } @@ -239,39 +241,24 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, */ if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0) - || (varFramePtr == NULL) - || !varFramePtr->isProcCallFrame - || (strstr(part1, "::") != NULL)) { + || (varFramePtr == NULL) + || !varFramePtr->isProcCallFrame + || (strstr(part1, "::") != NULL)) { char *tail; + /* + * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable, + * or otherwise generate our own error! + */ var = Tcl_FindNamespaceVar(interp, part1, (Tcl_Namespace *) NULL, - flags); + flags & ~TCL_LEAVE_ERR_MSG); if (var != (Tcl_Var) NULL) { varPtr = (Var *) var; } if (varPtr == NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_ResetResult(interp); - } if (createPart1) { /* var wasn't found so create it */ - result = TclGetNamespaceForQualName(interp, part1, - (Namespace *) NULL, flags, &varNsPtr, &dummy1Ptr, - &dummy2Ptr, &tail); - if (result != TCL_OK) { - if (flags & TCL_LEAVE_ERR_MSG) { - /* - * Move the interpreter's object result to the - * string result, then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REP HAS NULLS. - */ - - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), - TCL_VOLATILE); - } - goto done; - } + TclGetNamespaceForQualName(interp, part1, (Namespace *) NULL, + flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); if (varNsPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, msg, badNamespace); @@ -321,7 +308,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, if (createPart1) { if (tablePtr == NULL) { tablePtr = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); + ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); varFramePtr->varTablePtr = tablePtr; } @@ -350,7 +337,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, } } -lookupVarPart2: + lookupVarPart2: if (openParen != NULL) { *openParen = '('; openParen = NULL; @@ -387,10 +374,23 @@ lookupVarPart2: varPtr = NULL; goto done; } + + /* + * Make sure we are not resurrecting a namespace variable from a + * deleted namespace! + */ + if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, danglingVar); + } + varPtr = NULL; + goto done; + } + TclSetVarArray(varPtr); TclClearVarUndefined(varPtr); varPtr->value.tablePtr = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); } else if (!TclIsVarArray(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { @@ -472,7 +472,7 @@ Tcl_GetVar(interp, varName, flags) * bits. */ { return Tcl_GetVar2(interp, varName, (char *) NULL, - (flags | TCL_PARSE_PART1)); + (flags | TCL_PARSE_PART1)); } /* @@ -711,15 +711,15 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) if (compiledLocals == NULL) { fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); + (unsigned int) varFramePtr); } if ((localIndex < 0) || (localIndex >= localCt)) { fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); + localIndex, (unsigned int) varFramePtr, localCt); panic("TclGetIndexedScalar: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); } #endif /* TCL_COMPILE_DEBUG */ @@ -831,15 +831,15 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) if (compiledLocals == NULL) { fprintf(stderr, "\nTclGetElementOfIndexedArray: can't get element of local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); + (unsigned int) varFramePtr); } if ((localIndex < 0) || (localIndex >= localCt)) { fprintf(stderr, "\nTclGetIndexedScalar: can't get element of local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); + localIndex, (unsigned int) varFramePtr, localCt); panic("TclGetElementOfIndexedArray: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); } #endif /* TCL_COMPILE_DEBUG */ @@ -1030,7 +1030,7 @@ Tcl_SetVar(interp, varName, newValue, flags) * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ { return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, - (flags | TCL_PARSE_PART1)); + (flags | TCL_PARSE_PART1)); } /* @@ -1214,15 +1214,19 @@ Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) /* * If the variable is in a hashtable and its hPtr field is NULL, then we - * have an upvar to an array element where the array was deleted, - * leaving the element dangling at the end of the upvar. Generate an - * error (allowing the variable to be reset would screw up our storage - * allocation and is meaningless anyway). + * may have an upvar to an array element where the array was deleted + * or an upvar to a namespace variable whose namespace was deleted. + * Generate an error (allowing the variable to be reset would screw up + * our storage allocation and is meaningless anyway). */ if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, "set", danglingUpvar); + if (TclIsVarArrayElement(varPtr)) { + VarErrMsg(interp, part1, part2, "set", danglingElement); + } else { + VarErrMsg(interp, part1, part2, "set", danglingVar); + } } return NULL; } @@ -1312,7 +1316,7 @@ Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) neededBytes = Tcl_ScanElement(bytes, &listFlags); oldValuePtr = Tcl_NewObj(); oldValuePtr->bytes = (char *) - ckalloc((unsigned) (neededBytes + 1)); + ckalloc((unsigned) (neededBytes + 1)); oldValuePtr->length = Tcl_ConvertElement(bytes, oldValuePtr->bytes, listFlags); varPtr->value.objPtr = oldValuePtr; @@ -1439,15 +1443,15 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg) if (compiledLocals == NULL) { fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); + (unsigned int) varFramePtr); } if ((localIndex < 0) || (localIndex >= localCt)) { fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); + localIndex, (unsigned int) varFramePtr, localCt); panic("TclSetIndexedScalar: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); } #endif /* TCL_COMPILE_DEBUG */ @@ -1467,15 +1471,19 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg) /* * If the variable is in a hashtable and its hPtr field is NULL, then we - * have an upvar to an array element where the array was deleted, - * leaving the element dangling at the end of the upvar. Generate an - * error (allowing the variable to be reset would screw up our storage - * allocation and is meaningless anyway). + * may have an upvar to an array element where the array was deleted + * or an upvar to a namespace variable whose namespace was deleted. + * Generate an error (allowing the variable to be reset would screw up + * our storage allocation and is meaningless anyway). */ if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { if (leaveErrorMsg) { - VarErrMsg(interp, varName, NULL, "set", danglingUpvar); + if (TclIsVarArrayElement(varPtr)) { + VarErrMsg(interp, varName, NULL, "set", danglingElement); + } else { + VarErrMsg(interp, varName, NULL, "set", danglingVar); + } } return NULL; } @@ -1620,15 +1628,15 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, if (compiledLocals == NULL) { fprintf(stderr, "\nTclSetElementOfIndexedArray: can't set element of local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); + (unsigned int) varFramePtr); } if ((localIndex < 0) || (localIndex >= localCt)) { fprintf(stderr, "\nTclSetIndexedScalar: can't set elememt of local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); + localIndex, (unsigned int) varFramePtr, localCt); panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); } #endif /* TCL_COMPILE_DEBUG */ @@ -1652,13 +1660,32 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, } /* + * If the variable is in a hashtable and its hPtr field is NULL, then we + * may have an upvar to an array element where the array was deleted + * or an upvar to a namespace variable whose namespace was deleted. + * Generate an error (allowing the variable to be reset would screw up + * our storage allocation and is meaningless anyway). + */ + + if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) { + if (leaveErrorMsg) { + if (TclIsVarArrayElement(arrayPtr)) { + VarErrMsg(interp, arrayName, elem, "set", danglingElement); + } else { + VarErrMsg(interp, arrayName, elem, "set", danglingVar); + } + } + goto errorReturn; + } + + /* * Make sure we're dealing with an array. */ if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) { TclSetVarArray(arrayPtr); arrayPtr->value.tablePtr = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS); TclClearVarUndefined(arrayPtr); } else if (!TclIsVarArray(arrayPtr)) { @@ -1889,7 +1916,7 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount) int result; varValuePtr = TclGetIndexedScalar(interp, localIndex, - /*leaveErrorMsg*/ 1); + /*leaveErrorMsg*/ 1); if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); @@ -1923,7 +1950,7 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount) */ resultPtr = TclSetIndexedScalar(interp, localIndex, varValuePtr, - /*leaveErrorMsg*/ 1); + /*leaveErrorMsg*/ 1); if (resultPtr == NULL) { return NULL; } @@ -1976,7 +2003,7 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) int result; varValuePtr = TclGetElementOfIndexedArray(interp, localIndex, elemPtr, - /*leaveErrorMsg*/ 1); + /*leaveErrorMsg*/ 1); if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); @@ -2010,8 +2037,8 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) */ resultPtr = TclSetElementOfIndexedArray(interp, localIndex, elemPtr, - varValuePtr, - /*leaveErrorMsg*/ 1); + varValuePtr, + /*leaveErrorMsg*/ 1); if (resultPtr == NULL) { return NULL; } @@ -2146,7 +2173,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) ckfree((char *) tracePtr); } for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; } @@ -2164,7 +2191,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) dummyVarPtr = &dummyVar; if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) { DeleteArray(iPtr, part1, dummyVarPtr, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); } if (TclIsVarScalar(dummyVarPtr) && (dummyVarPtr->value.objPtr != NULL)) { @@ -2174,9 +2201,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) } /* - * If the variable was a namespace variable, decrement its reference - * count. We are in the process of destroying its namespace so that - * namespace will no longer "refer" to the variable. + * If the variable was a namespace variable, decrement its reference count. */ if (varPtr->flags & VAR_NAMESPACE_VAR) { @@ -2299,7 +2324,7 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = - flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS); + flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS); tracePtr->nextPtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr; return TCL_OK; @@ -2337,7 +2362,7 @@ Tcl_UntraceVar(interp, varName, flags, proc, clientData) ClientData clientData; /* Arbitrary argument to pass to proc. */ { Tcl_UntraceVar2(interp, varName, (char *) NULL, - (flags | TCL_PARSE_PART1), proc, clientData); + (flags | TCL_PARSE_PART1), proc, clientData); } /* @@ -2390,7 +2415,7 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS); for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; - prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { return; } @@ -2407,7 +2432,7 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) */ for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->nextTracePtr == tracePtr) { activePtr->nextTracePtr = tracePtr->nextPtr; } @@ -2613,8 +2638,8 @@ Tcl_AppendObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { register Tcl_Obj *varValuePtr = NULL; - /* Initialized to avoid compiler - * warning. */ + /* Initialized to avoid compiler + * warning. */ int i; if (objc < 2) { @@ -2631,8 +2656,8 @@ Tcl_AppendObjCmd(dummy, interp, objc, objv) } else { for (i = 2; i < objc; i++) { varValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL, - objv[i], - (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + objv[i], + (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); if (varValuePtr == NULL) { return TCL_ERROR; } @@ -2680,7 +2705,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) if (objc == 2) { newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, - (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); if (newValuePtr == NULL) { /* * The variable doesn't exist yet. Just create it with an empty @@ -2763,7 +2788,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) if (numRequired > listRepPtr->maxElemCount) { int newMax = (2 * numRequired); Tcl_Obj **newElemPtrs = (Tcl_Obj **) - ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); + ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); memcpy((VOID *) newElemPtrs, (VOID *) elemPtrs, (size_t) (numElems * sizeof(Tcl_Obj *))); @@ -2849,8 +2874,8 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, ARRAY_STARTSEARCH}; static char *arrayOptions[] = {"anymore", "donesearch", "exists", - "get", "names", "nextelement", "set", "size", "startsearch", - (char *) NULL}; + "get", "names", "nextelement", "set", "size", "startsearch", + (char *) NULL}; Var *varPtr, *arrayPtr; Tcl_HashEntry *hPtr; @@ -2942,7 +2967,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) varPtr->searchPtr = searchPtr->nextPtr; } else { for (prevPtr = varPtr->searchPtr; ; - prevPtr = prevPtr->nextPtr) { + prevPtr = prevPtr->nextPtr) { if (prevPtr->nextPtr == searchPtr) { prevPtr->nextPtr = searchPtr->nextPtr; break; @@ -2978,7 +3003,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL); } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarUndefined(varPtr2)) { continue; @@ -3029,7 +3054,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL); } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarUndefined(varPtr2)) { continue; @@ -3154,7 +3179,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) varPtr->value.tablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); - return TCL_OK; + return TCL_OK; } case ARRAY_SIZE: { Tcl_HashSearch search; @@ -3169,7 +3194,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (!notArray) { for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarUndefined(varPtr2)) { continue; @@ -3201,7 +3226,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) searchPtr->id = varPtr->searchPtr->id + 1; TclFormatInt(string, searchPtr->id); Tcl_AppendStringsToObj(resultPtr, "s-", string, "-", varName, - (char *) NULL); + (char *) NULL); } searchPtr->varPtr = varPtr; searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, @@ -3260,7 +3285,7 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) Tcl_HashTable *tablePtr; Namespace *nsPtr, *altNsPtr, *dummyNsPtr; char *tail; - int new, result; + int new; /* * Find "other" in "framePtr". If not looking up other in just the @@ -3299,21 +3324,18 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) varFramePtr = iPtr->varFramePtr; if ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) - || (varFramePtr == NULL) - || !varFramePtr->isProcCallFrame - || (strstr(myName, "::") != NULL)) { - result = TclGetNamespaceForQualName((Tcl_Interp *) iPtr, myName, - (Namespace *) NULL, (myFlags | TCL_LEAVE_ERR_MSG), - &nsPtr, &altNsPtr, &dummyNsPtr, &tail); - if (result != TCL_OK) { - return result; - } + || (varFramePtr == NULL) + || !varFramePtr->isProcCallFrame + || (strstr(myName, "::") != NULL)) { + TclGetNamespaceForQualName((Tcl_Interp *) iPtr, myName, + (Namespace *) NULL, myFlags, &nsPtr, &altNsPtr, &dummyNsPtr, &tail); + if (nsPtr == NULL) { nsPtr = altNsPtr; } if (nsPtr == NULL) { Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - myName, "\": unknown namespace", (char *) NULL); + myName, "\": unknown namespace", (char *) NULL); return TCL_ERROR; } @@ -3406,11 +3428,11 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) } } else if (!TclIsVarUndefined(varPtr)) { Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" already exists", (char *) NULL); + "\" already exists", (char *) NULL); return TCL_ERROR; } else if (varPtr->tracePtr != NULL) { Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" has traces: can't use for upvar", (char *) NULL); + "\" has traces: can't use for upvar", (char *) NULL); return TCL_ERROR; } } @@ -3717,7 +3739,7 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - char *varName, *tail; + char *varName, *tail, *cp; Var *varPtr, *arrayPtr; Tcl_Obj *varValuePtr; int i, result; @@ -3773,17 +3795,17 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) /* * varName might have a scope qualifier, but the name for the * local "link" variable must be the simple name at the tail. + * + * Locate tail in one pass: drop any prefix after two *or more* + * consecutive ":" characters). */ - for (tail = varName; *tail != '\0'; tail++) { - /* empty body */ - } - while ((tail > varName) - && ((*tail != ':') || (*(tail-1) != ':'))) { - tail--; - } - if (*tail == ':') { - tail++; + for (tail = cp = varName; *cp != '\0'; ) { + if (*cp++ == ':') { + while (*cp++ == ':') { + tail = cp; + } + } } /* @@ -3983,7 +4005,7 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) Tcl_DStringInit(&nameCopy); Tcl_DStringAppend(&nameCopy, part1, (p-part1)); part2 = Tcl_DStringValue(&nameCopy) - + (openParen + 1 - part1); + + (openParen + 1 - part1); part2[-1] = 0; part1 = Tcl_DStringValue(&nameCopy); copiedName = 1; @@ -4005,7 +4027,7 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) arrayPtr->refCount++; active.varPtr = arrayPtr; for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; - tracePtr = active.nextTracePtr) { + tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; @@ -4031,7 +4053,7 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) } active.varPtr = varPtr; for (tracePtr = varPtr->tracePtr; tracePtr != NULL; - tracePtr = active.nextTracePtr) { + tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; @@ -4163,7 +4185,7 @@ ParseSearchId(interp, varPtr, varName, string) */ for (searchPtr = varPtr->searchPtr; searchPtr != NULL; - searchPtr = searchPtr->nextPtr) { + searchPtr = searchPtr->nextPtr) { if (searchPtr->id == id) { return searchPtr; } @@ -4253,7 +4275,7 @@ TclDeleteVars(iPtr, tablePtr) } for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { + hPtr = Tcl_NextHashEntry(&search)) { varPtr = (Var *) Tcl_GetHashValue(hPtr); /* @@ -4304,7 +4326,7 @@ TclDeleteVars(iPtr, tablePtr) ckfree((char *) tracePtr); } for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; } @@ -4428,7 +4450,7 @@ TclDeleteCompiledLocalVars(iPtr, framePtr) ckfree((char *) tracePtr); } for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; } @@ -4498,7 +4520,7 @@ DeleteArray(iPtr, arrayName, varPtr, flags) DeleteSearches(varPtr); for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { elPtr = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) { objPtr = elPtr->value.objPtr; @@ -4516,7 +4538,7 @@ DeleteArray(iPtr, arrayName, varPtr, flags) ckfree((char *) tracePtr); } for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == elPtr) { activePtr->nextTracePtr = NULL; } @@ -4610,7 +4632,7 @@ VarErrMsg(interp, part1, part2, operation, reason) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't ", operation, " \"", part1, - (char *) NULL); + (char *) NULL); if (part2 != NULL) { Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL); } diff --git a/tests/var.test b/tests/var.test index 735b0ee..981c649 100644 --- a/tests/var.test +++ b/tests/var.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: var.test,v 1.3 1998/09/14 18:40:15 stanton Exp $ +# RCS: @(#) $Id: var.test,v 1.4 1999/02/03 00:55:07 stanton Exp $ # if {[string compare test [info procs test]] == 1} then {source defs} @@ -113,6 +113,62 @@ test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of va [expr {[lsearch [info vars] x:y:] != -1}] } } {123 456 789 123 456 789 1 1 1} +test var-1.15 {TclLookupVar, resurrect variable via upvar to deleted namespace: compiled code path} { + namespace eval test_ns_var { + variable foo 2 + } + proc p {} { + variable ::test_ns_var::foo + lappend result [catch {set foo} msg] $msg + namespace delete ::test_ns_var + lappend result [catch {set foo 3} msg] $msg + lappend result [catch {set foo(3) 3} msg] $msg + } + p +} {0 2 1 {can't set "foo": upvar refers to variable in deleted namespace} 1 {can't set "foo(3)": upvar refers to variable in deleted namespace}} +test var-1.16 {TclLookupVar, resurrect variable via upvar to deleted namespace: uncompiled code path} { + namespace eval test_ns_var { + variable result + namespace eval subns { + variable foo 2 + } + upvar 0 subns::foo foo + lappend result [catch {set foo} msg] $msg + namespace delete subns + lappend result [catch {set foo 3} msg] $msg + lappend result [catch {set foo(3) 3} msg] $msg + namespace delete [namespace current] + set result + } +} {0 2 1 {can't set "foo": upvar refers to variable in deleted namespace} 1 {can't set "foo(3)": upvar refers to variable in deleted namespace}} +test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array: compiled code path} { + namespace eval test_ns_var { + variable result + proc p {} { + array set x {1 2 3 4} + upvar 0 x(1) foo + lappend result [catch {set foo} msg] $msg + unset x + lappend result [catch {set foo 3} msg] $msg + } + set result [p] + namespace delete [namespace current] + set result + } +} {0 2 1 {can't set "foo": upvar refers to element in deleted array}} +test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} { + namespace eval test_ns_var { + variable result {} + variable x + array set x {1 2 3 4} + upvar 0 x(1) foo + lappend result [catch {set foo} msg] $msg + unset x + lappend result [catch {set foo 3} msg] $msg + namespace delete [namespace current] + set result + } +} {0 2 1 {can't set "foo": upvar refers to element in deleted array}} test var-2.1 {Tcl_LappendObjCmd, create var if new} { catch {unset x} @@ -389,6 +445,16 @@ test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link v } p } {{My name is empty} {{}}} +test var-7.13 {Tcl_VariableObjCmd, variable named ":"} { + namespace eval test_ns_var { + variable : {My name is ":"} + proc p {} { + variable : + list [set :] [info vars] + } + p + } +} {{My name is ":"} :} test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} { catch {namespace delete test_ns_var} @@ -411,48 +477,98 @@ if {[info commands testsetnoerr] == {}} { puts "This application hasn't been compiled with the \"testsetnoerr\"" puts "command, so I can't test TclSetVar etc." } else { -test var-9.1 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { - testsetnoerr v 1 -} 1 -test var-9.2 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { - catch {unset v} - list [catch {testsetnoerr v} res] $res; -} {1 {before get}} -test var-9.3 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { - catch {unset arr} - set arr(1) 1; - list [catch {testsetnoerr arr} res] $res; -} {1 {before get}} -test var-9.4 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { - namespace eval ns {variable v nsv} - testsetnoerr ns::v; -} nsv; -test var-9.5 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { - catch {namespace delete ns} - list [catch {testsetnoerr ns::v} res] $res; -} {1 {before get}} -test var-9.6 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { - catch {unset arr} - set arr(1) 1; - list [catch {testsetnoerr arr 2} res] $res; -} {1 {before set}} -test var-9.7 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { - catch {unset arr} - set arr(1) 1; - list [catch {testsetnoerr arr 2} res] $res; -} {1 {before set}} -test var-9.8 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { - # this test currently fails, should not... - # (some namespace function resets the interp while it should not) +test var-9.1 {behaviour of TclGet/SetVar simple get/set} { + catch {unset u}; catch {unset v} + list \ + [set u a; testsetnoerr u] \ + [testsetnoerr v b] \ + [testseterr u] \ + [unset v; testseterr v b] +} [list {before get a} {before set b} {before get a} {before set b}] +test var-9.2 {behaviour of TclGet/SetVar namespace get/set} { + catch {namespace delete ns} + namespace eval ns {variable u a; variable v} + list \ + [testsetnoerr ns::u] \ + [testsetnoerr ns::v b] \ + [testseterr ns::u] \ + [unset ns::v; testseterr ns::v b] +} [list {before get a} {before set b} {before get a} {before set b}] +test var-9.3 {behaviour of TclGetVar no variable} { + catch {unset u} + list \ + [catch {testsetnoerr u} res] $res \ + [catch {testseterr u} res] $res +} {1 {before get} 1 {can't read "u": no such variable}} +test var-9.4 {behaviour of TclGetVar no namespace variable} { + catch {namespace delete ns} + namespace eval ns {} + list \ + [catch {testsetnoerr ns::w} res] $res \ + [catch {testseterr ns::w} res] $res +} {1 {before get} 1 {can't read "ns::w": no such variable}} +test var-9.5 {behaviour of TclGetVar no namespace} { catch {namespace delete ns} - list [catch {testsetnoerr ns::v 1} res] $res; -} {1 {before set}} -test var-9.9 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { + list \ + [catch {testsetnoerr ns::u} res] $res \ + [catch {testseterr ns::v} res] $res +} {1 {before get} 1 {can't read "ns::v": no such variable}} +test var-9.6 {behaviour of TclSetVar no namespace} { + catch {namespace delete ns} + list \ + [catch {testsetnoerr ns::v 1} res] $res \ + [catch {testseterr ns::v 1} res] $res +} {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}} +test var-9.7 {behaviour of TclGetVar array variable} { + catch {unset arr} + set arr(1) 1; + list \ + [catch {testsetnoerr arr} res] $res \ + [catch {testseterr arr} res] $res +} {1 {before get} 1 {can't read "arr": variable is array}} +test var-9.8 {behaviour of TclSetVar array variable} { + catch {unset arr} + set arr(1) 1 + list \ + [catch {testsetnoerr arr 2} res] $res \ + [catch {testseterr arr 2} res] $res +} {1 {before set} 1 {can't set "arr": variable is array}} +test var-9.9 {behaviour of TclGetVar read trace success} { + proc resetvar {val name elem op} {upvar 1 $name v; set v $val} + catch {unset u}; catch {unset v} + set u 10 + trace var u r [list resetvar 1] + trace var v r [list resetvar 2] + list \ + [testsetnoerr u] \ + [testseterr v] +} {{before get 1} {before get 2}} +test var-9.10 {behaviour of TclGetVar read trace error} { + proc writeonly args {error "write-only"} + set v 456 + trace var v r writeonly + list \ + [catch {testsetnoerr v} msg] $msg \ + [catch {testseterr v} msg] $msg +} {1 {before get} 1 {can't read "v": write-only}} +test var-9.11 {behaviour of TclSetVar write trace success} { + proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]} + catch {unset u}; catch {unset v} + set v 1 + trace var v w doubleval + trace var u w doubleval + list \ + [testsetnoerr u 2] \ + [testseterr v 3] +} {{before set 4} {before set 6}} +test var-9.12 {behaviour of TclSetVar write trace error} { proc readonly args {error "read-only"} set v 456 trace var v w readonly - list [catch {testsetnoerr v 2} msg] $msg -} {1 {before set}} + list \ + [catch {testsetnoerr v 2} msg] $msg $v \ + [catch {testseterr v 3} msg] $msg $v +} {1 {before set} 2 1 {can't set "v": read-only} 3} } catch {namespace delete ns} -- cgit v0.12