summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclBasic.c31
-rw-r--r--generic/tclCmdIL.c24
-rw-r--r--generic/tclCompile.c6
-rw-r--r--generic/tclInt.h6
-rw-r--r--generic/tclNamesp.c137
-rw-r--r--generic/tclProc.c12
-rw-r--r--generic/tclTest.c60
-rw-r--r--generic/tclVar.c268
-rw-r--r--tests/var.test194
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}
generated by cgit v0.12 at 2024-11-03 10:51:44 (GMT)