os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclVar.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclVar.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,5322 @@
1.4 +/*
1.5 + * tclVar.c --
1.6 + *
1.7 + * This file contains routines that implement Tcl variables
1.8 + * (both scalars and arrays).
1.9 + *
1.10 + * The implementation of arrays is modelled after an initial
1.11 + * implementation by Mark Diekhans and Karl Lehenbauer.
1.12 + *
1.13 + * Copyright (c) 1987-1994 The Regents of the University of California.
1.14 + * Copyright (c) 1994-1997 Sun Microsystems, Inc.
1.15 + * Copyright (c) 1998-1999 by Scriptics Corporation.
1.16 + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
1.17 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.18 + *
1.19 + * See the file "license.terms" for information on usage and redistribution
1.20 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.21 + *
1.22 + * RCS: @(#) $Id: tclVar.c,v 1.69.2.14 2007/05/10 18:23:58 dgp Exp $
1.23 + */
1.24 +
1.25 +#include "tclInt.h"
1.26 +#include "tclPort.h"
1.27 +
1.28 +
1.29 +/*
1.30 + * The strings below are used to indicate what went wrong when a
1.31 + * variable access is denied.
1.32 + */
1.33 +
1.34 +static CONST char *noSuchVar = "no such variable";
1.35 +static CONST char *isArray = "variable is array";
1.36 +static CONST char *needArray = "variable isn't array";
1.37 +static CONST char *noSuchElement = "no such element in array";
1.38 +static CONST char *danglingElement =
1.39 + "upvar refers to element in deleted array";
1.40 +static CONST char *danglingVar =
1.41 + "upvar refers to variable in deleted namespace";
1.42 +static CONST char *badNamespace = "parent namespace doesn't exist";
1.43 +static CONST char *missingName = "missing variable name";
1.44 +static CONST char *isArrayElement = "name refers to an element in an array";
1.45 +
1.46 +/*
1.47 + * Forward references to procedures defined later in this file:
1.48 + */
1.49 +
1.50 +static int CallVarTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
1.51 + Var *varPtr, CONST char *part1, CONST char *part2,
1.52 + int flags, CONST int leaveErrMsg));
1.53 +static void CleanupVar _ANSI_ARGS_((Var *varPtr,
1.54 + Var *arrayPtr));
1.55 +static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
1.56 +static void DeleteArray _ANSI_ARGS_((Interp *iPtr,
1.57 + CONST char *arrayName, Var *varPtr, int flags));
1.58 +static void DisposeTraceResult _ANSI_ARGS_((int flags,
1.59 + char *result));
1.60 +static int ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp,
1.61 + CallFrame *framePtr, Tcl_Obj *otherP1Ptr,
1.62 + CONST char *otherP2, CONST int otherFlags,
1.63 + CONST char *myName, int myFlags, int index));
1.64 +static Var * NewVar _ANSI_ARGS_((void));
1.65 +static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
1.66 + CONST Var *varPtr, CONST char *varName,
1.67 + Tcl_Obj *handleObj));
1.68 +static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
1.69 + CONST char *part1, CONST char *part2,
1.70 + CONST char *operation, CONST char *reason));
1.71 +static int SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp,
1.72 + Tcl_Obj *objPtr));
1.73 +static void UnsetVarStruct _ANSI_ARGS_((Var *varPtr, Var *arrayPtr,
1.74 + Interp *iPtr, CONST char *part1, CONST char *part2,
1.75 + int flags));
1.76 +
1.77 +/*
1.78 + * Functions defined in this file that may be exported in the future
1.79 + * for use by the bytecode compiler and engine or to the public interface.
1.80 + */
1.81 +
1.82 +Var * TclLookupSimpleVar _ANSI_ARGS_((Tcl_Interp *interp,
1.83 + CONST char *varName, int flags, CONST int create,
1.84 + CONST char **errMsgPtr, int *indexPtr));
1.85 +int TclObjUnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
1.86 + Tcl_Obj *part1Ptr, CONST char *part2, int flags));
1.87 +
1.88 +static Tcl_FreeInternalRepProc FreeLocalVarName;
1.89 +static Tcl_DupInternalRepProc DupLocalVarName;
1.90 +static Tcl_UpdateStringProc UpdateLocalVarName;
1.91 +static Tcl_FreeInternalRepProc FreeNsVarName;
1.92 +static Tcl_DupInternalRepProc DupNsVarName;
1.93 +static Tcl_FreeInternalRepProc FreeParsedVarName;
1.94 +static Tcl_DupInternalRepProc DupParsedVarName;
1.95 +static Tcl_UpdateStringProc UpdateParsedVarName;
1.96 +
1.97 +/*
1.98 + * Types of Tcl_Objs used to cache variable lookups.
1.99 + *
1.100 + *
1.101 + * localVarName - INTERNALREP DEFINITION:
1.102 + * twoPtrValue.ptr1 = pointer to the corresponding Proc
1.103 + * twoPtrValue.ptr2 = index into locals table
1.104 + *
1.105 + * nsVarName - INTERNALREP DEFINITION:
1.106 + * twoPtrValue.ptr1: pointer to the namespace containing the
1.107 + * reference
1.108 + * twoPtrValue.ptr2: pointer to the corresponding Var
1.109 + *
1.110 + * parsedVarName - INTERNALREP DEFINITION:
1.111 + * twoPtrValue.ptr1 = pointer to the array name Tcl_Obj,
1.112 + * or NULL if it is a scalar variable
1.113 + * twoPtrValue.ptr2 = pointer to the element name string
1.114 + * (owned by this Tcl_Obj), or NULL if
1.115 + * it is a scalar variable
1.116 + */
1.117 +
1.118 +static Tcl_ObjType tclLocalVarNameType = {
1.119 + "localVarName",
1.120 + FreeLocalVarName, DupLocalVarName, UpdateLocalVarName, NULL
1.121 +};
1.122 +
1.123 +static Tcl_ObjType tclNsVarNameType = {
1.124 + "namespaceVarName",
1.125 + FreeNsVarName, DupNsVarName, NULL, NULL
1.126 +};
1.127 +
1.128 +static Tcl_ObjType tclParsedVarNameType = {
1.129 + "parsedVarName",
1.130 + FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, NULL
1.131 +};
1.132 +
1.133 +/*
1.134 + * Type of Tcl_Objs used to speed up array searches.
1.135 + *
1.136 + * INTERNALREP DEFINITION:
1.137 + * twoPtrValue.ptr1 = searchIdNumber as offset from (char*)NULL
1.138 + * twoPtrValue.ptr2 = variableNameStartInString as offset from (char*)NULL
1.139 + *
1.140 + * Note that the value stored in ptr2 is the offset into the string of
1.141 + * the start of the variable name and not the address of the variable
1.142 + * name itself, as this can be safely copied.
1.143 + */
1.144 +Tcl_ObjType tclArraySearchType = {
1.145 + "array search",
1.146 + NULL, NULL, NULL, SetArraySearchObj
1.147 +};
1.148 +
1.149 +
1.150 +/*
1.151 + *----------------------------------------------------------------------
1.152 + *
1.153 + * TclLookupVar --
1.154 + *
1.155 + * This procedure is used to locate a variable given its name(s). It
1.156 + * has been mostly superseded by TclObjLookupVar, it is now only used
1.157 + * by the string-based interfaces. It is kept in tcl8.4 mainly because
1.158 + * it is in the internal stubs table, so that some extension may be
1.159 + * calling it.
1.160 + *
1.161 + * Results:
1.162 + * The return value is a pointer to the variable structure indicated by
1.163 + * part1 and part2, or NULL if the variable couldn't be found. If the
1.164 + * variable is found, *arrayPtrPtr is filled in with the address of the
1.165 + * variable structure for the array that contains the variable (or NULL
1.166 + * if the variable is a scalar). If the variable can't be found and
1.167 + * either createPart1 or createPart2 are 1, a new as-yet-undefined
1.168 + * (VAR_UNDEFINED) variable structure is created, entered into a hash
1.169 + * table, and returned.
1.170 + *
1.171 + * If the variable isn't found and creation wasn't specified, or some
1.172 + * other error occurs, NULL is returned and an error message is left in
1.173 + * the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
1.174 + *
1.175 + * Note: it's possible for the variable returned to be VAR_UNDEFINED
1.176 + * even if createPart1 or createPart2 are 1 (these only cause the hash
1.177 + * table entry or array to be created). For example, the variable might
1.178 + * be a global that has been unset but is still referenced by a
1.179 + * procedure, or a variable that has been unset but it only being kept
1.180 + * in existence (if VAR_UNDEFINED) by a trace.
1.181 + *
1.182 + * Side effects:
1.183 + * New hashtable entries may be created if createPart1 or createPart2
1.184 + * are 1.
1.185 + *
1.186 + *----------------------------------------------------------------------
1.187 + */
1.188 +Var *
1.189 +TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,
1.190 + arrayPtrPtr)
1.191 + Tcl_Interp *interp; /* Interpreter to use for lookup. */
1.192 + CONST char *part1; /* If part2 isn't NULL, this is the name of
1.193 + * an array. Otherwise, this
1.194 + * is a full variable name that could
1.195 + * include a parenthesized array element. */
1.196 + CONST char *part2; /* Name of element within array, or NULL. */
1.197 + int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
1.198 + * and TCL_LEAVE_ERR_MSG bits matter. */
1.199 + CONST char *msg; /* Verb to use in error messages, e.g.
1.200 + * "read" or "set". Only needed if
1.201 + * TCL_LEAVE_ERR_MSG is set in flags. */
1.202 + int createPart1; /* If 1, create hash table entry for part 1
1.203 + * of name, if it doesn't already exist. If
1.204 + * 0, return error if it doesn't exist. */
1.205 + int createPart2; /* If 1, create hash table entry for part 2
1.206 + * of name, if it doesn't already exist. If
1.207 + * 0, return error if it doesn't exist. */
1.208 + Var **arrayPtrPtr; /* If the name refers to an element of an
1.209 + * array, *arrayPtrPtr gets filled in with
1.210 + * address of array variable. Otherwise
1.211 + * this is set to NULL. */
1.212 +{
1.213 + Var *varPtr;
1.214 + CONST char *elName; /* Name of array element or NULL; may be
1.215 + * same as part2, or may be openParen+1. */
1.216 + int openParen, closeParen;
1.217 + /* If this procedure parses a name into
1.218 + * array and index, these are the offsets to
1.219 + * the parens around the index. Otherwise
1.220 + * they are -1. */
1.221 + register CONST char *p;
1.222 + CONST char *errMsg = NULL;
1.223 + int index;
1.224 +#define VAR_NAME_BUF_SIZE 26
1.225 + char buffer[VAR_NAME_BUF_SIZE];
1.226 + char *newVarName = buffer;
1.227 +
1.228 + varPtr = NULL;
1.229 + *arrayPtrPtr = NULL;
1.230 + openParen = closeParen = -1;
1.231 +
1.232 + /*
1.233 + * Parse part1 into array name and index.
1.234 + * Always check if part1 is an array element name and allow it only if
1.235 + * part2 is not given.
1.236 + * (if one does not care about creating array elements that can't be used
1.237 + * from tcl, and prefer slightly better performance, one can put
1.238 + * the following in an if (part2 == NULL) { ... } block and remove
1.239 + * the part2's test and error reporting or move that code in array set)
1.240 + */
1.241 +
1.242 + elName = part2;
1.243 + for (p = part1; *p ; p++) {
1.244 + if (*p == '(') {
1.245 + openParen = p - part1;
1.246 + do {
1.247 + p++;
1.248 + } while (*p != '\0');
1.249 + p--;
1.250 + if (*p == ')') {
1.251 + if (part2 != NULL) {
1.252 + if (flags & TCL_LEAVE_ERR_MSG) {
1.253 + VarErrMsg(interp, part1, part2, msg, needArray);
1.254 + }
1.255 + return NULL;
1.256 + }
1.257 + closeParen = p - part1;
1.258 + } else {
1.259 + openParen = -1;
1.260 + }
1.261 + break;
1.262 + }
1.263 + }
1.264 + if (openParen != -1) {
1.265 + if (closeParen >= VAR_NAME_BUF_SIZE) {
1.266 + newVarName = ckalloc((unsigned int) (closeParen+1));
1.267 + }
1.268 + memcpy(newVarName, part1, (unsigned int) closeParen);
1.269 + newVarName[openParen] = '\0';
1.270 + newVarName[closeParen] = '\0';
1.271 + part1 = newVarName;
1.272 + elName = newVarName + openParen + 1;
1.273 + }
1.274 +
1.275 + varPtr = TclLookupSimpleVar(interp, part1, flags,
1.276 + createPart1, &errMsg, &index);
1.277 + if (varPtr == NULL) {
1.278 + if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
1.279 + VarErrMsg(interp, part1, elName, msg, errMsg);
1.280 + }
1.281 + } else {
1.282 + while (TclIsVarLink(varPtr)) {
1.283 + varPtr = varPtr->value.linkPtr;
1.284 + }
1.285 + if (elName != NULL) {
1.286 + *arrayPtrPtr = varPtr;
1.287 + varPtr = TclLookupArrayElement(interp, part1, elName, flags,
1.288 + msg, createPart1, createPart2, varPtr);
1.289 + }
1.290 + }
1.291 + if (newVarName != buffer) {
1.292 + ckfree(newVarName);
1.293 + }
1.294 +
1.295 + return varPtr;
1.296 +
1.297 +#undef VAR_NAME_BUF_SIZE
1.298 +}
1.299 +
1.300 +/*
1.301 + *----------------------------------------------------------------------
1.302 + *
1.303 + * TclObjLookupVar --
1.304 + *
1.305 + * This procedure is used by virtually all of the variable code to
1.306 + * locate a variable given its name(s). The parsing into array/element
1.307 + * components and (if possible) the lookup results are cached in
1.308 + * part1Ptr, which is converted to one of the varNameTypes.
1.309 + *
1.310 + * Results:
1.311 + * The return value is a pointer to the variable structure indicated by
1.312 + * part1Ptr and part2, or NULL if the variable couldn't be found. If
1.313 + * the variable is found, *arrayPtrPtr is filled with the address of the
1.314 + * variable structure for the array that contains the variable (or NULL
1.315 + * if the variable is a scalar). If the variable can't be found and
1.316 + * either createPart1 or createPart2 are 1, a new as-yet-undefined
1.317 + * (VAR_UNDEFINED) variable structure is created, entered into a hash
1.318 + * table, and returned.
1.319 + *
1.320 + * If the variable isn't found and creation wasn't specified, or some
1.321 + * other error occurs, NULL is returned and an error message is left in
1.322 + * the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
1.323 + *
1.324 + * Note: it's possible for the variable returned to be VAR_UNDEFINED
1.325 + * even if createPart1 or createPart2 are 1 (these only cause the hash
1.326 + * table entry or array to be created). For example, the variable might
1.327 + * be a global that has been unset but is still referenced by a
1.328 + * procedure, or a variable that has been unset but it only being kept
1.329 + * in existence (if VAR_UNDEFINED) by a trace.
1.330 + *
1.331 + * Side effects:
1.332 + * New hashtable entries may be created if createPart1 or createPart2
1.333 + * are 1.
1.334 + * The object part1Ptr is converted to one of tclLocalVarNameType,
1.335 + * tclNsVarNameType or tclParsedVarNameType and caches as much of the
1.336 + * lookup as it can.
1.337 + *
1.338 + *----------------------------------------------------------------------
1.339 + */
1.340 +Var *
1.341 +TclObjLookupVar(interp, part1Ptr, part2, flags, msg, createPart1, createPart2,
1.342 + arrayPtrPtr)
1.343 + Tcl_Interp *interp; /* Interpreter to use for lookup. */
1.344 + register Tcl_Obj *part1Ptr; /* If part2 isn't NULL, this is the name
1.345 + * of an array. Otherwise, this is a full
1.346 + * variable name that could include a parenthesized
1.347 + * array element. */
1.348 + CONST char *part2; /* Name of element within array, or NULL. */
1.349 + int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
1.350 + * and TCL_LEAVE_ERR_MSG bits matter. */
1.351 + CONST char *msg; /* Verb to use in error messages, e.g.
1.352 + * "read" or "set". Only needed if
1.353 + * TCL_LEAVE_ERR_MSG is set in flags. */
1.354 + CONST int createPart1; /* If 1, create hash table entry for part 1
1.355 + * of name, if it doesn't already exist. If
1.356 + * 0, return error if it doesn't exist. */
1.357 + CONST int createPart2; /* If 1, create hash table entry for part 2
1.358 + * of name, if it doesn't already exist. If
1.359 + * 0, return error if it doesn't exist. */
1.360 + Var **arrayPtrPtr; /* If the name refers to an element of an
1.361 + * array, *arrayPtrPtr gets filled in with
1.362 + * address of array variable. Otherwise
1.363 + * this is set to NULL. */
1.364 +{
1.365 + Interp *iPtr = (Interp *) interp;
1.366 + register Var *varPtr; /* Points to the variable's in-frame Var
1.367 + * structure. */
1.368 + char *part1;
1.369 + int index, len1, len2;
1.370 + int parsed = 0;
1.371 + Tcl_Obj *objPtr;
1.372 + Tcl_ObjType *typePtr = part1Ptr->typePtr;
1.373 + CONST char *errMsg = NULL;
1.374 + CallFrame *varFramePtr = iPtr->varFramePtr;
1.375 + Namespace *nsPtr;
1.376 +
1.377 + /*
1.378 + * If part1Ptr is a tclParsedVarNameType, separate it into the
1.379 + * pre-parsed parts.
1.380 + */
1.381 +
1.382 + *arrayPtrPtr = NULL;
1.383 + if (typePtr == &tclParsedVarNameType) {
1.384 + if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {
1.385 + if (part2 != NULL) {
1.386 + /*
1.387 + * ERROR: part1Ptr is already an array element, cannot
1.388 + * specify a part2.
1.389 + */
1.390 +
1.391 + if (flags & TCL_LEAVE_ERR_MSG) {
1.392 + part1 = TclGetString(part1Ptr);
1.393 + VarErrMsg(interp, part1, part2, msg, needArray);
1.394 + }
1.395 + return NULL;
1.396 + }
1.397 + part2 = (char *) part1Ptr->internalRep.twoPtrValue.ptr2;
1.398 + part1Ptr = (Tcl_Obj *) part1Ptr->internalRep.twoPtrValue.ptr1;
1.399 + typePtr = part1Ptr->typePtr;
1.400 + }
1.401 + parsed = 1;
1.402 + }
1.403 + part1 = Tcl_GetStringFromObj(part1Ptr, &len1);
1.404 +
1.405 + nsPtr = ((varFramePtr == NULL)? iPtr->globalNsPtr : varFramePtr->nsPtr);
1.406 + if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
1.407 + goto doParse;
1.408 + }
1.409 +
1.410 + if (typePtr == &tclLocalVarNameType) {
1.411 + Proc *procPtr = (Proc *) part1Ptr->internalRep.twoPtrValue.ptr1;
1.412 + int localIndex = (int) part1Ptr->internalRep.twoPtrValue.ptr2;
1.413 + int useLocal;
1.414 +
1.415 + useLocal = ((varFramePtr != NULL) && varFramePtr->isProcCallFrame
1.416 + && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)));
1.417 + if (useLocal && (procPtr == varFramePtr->procPtr)) {
1.418 + /*
1.419 + * part1Ptr points to an indexed local variable of the
1.420 + * correct procedure: use the cached value.
1.421 + */
1.422 +
1.423 + varPtr = &(varFramePtr->compiledLocals[localIndex]);
1.424 + goto donePart1;
1.425 + }
1.426 + goto doneParsing;
1.427 + } else if (typePtr == &tclNsVarNameType) {
1.428 + Namespace *cachedNsPtr;
1.429 + int useGlobal, useReference;
1.430 +
1.431 + varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2;
1.432 + cachedNsPtr = (Namespace *) part1Ptr->internalRep.twoPtrValue.ptr1;
1.433 + useGlobal = (cachedNsPtr == iPtr->globalNsPtr)
1.434 + && ((flags & TCL_GLOBAL_ONLY)
1.435 + || ((*part1 == ':') && (*(part1+1) == ':'))
1.436 + || (varFramePtr == NULL)
1.437 + || (!varFramePtr->isProcCallFrame
1.438 + && (nsPtr == iPtr->globalNsPtr)));
1.439 + useReference = useGlobal || ((cachedNsPtr == nsPtr)
1.440 + && ((flags & TCL_NAMESPACE_ONLY)
1.441 + || (varFramePtr && !varFramePtr->isProcCallFrame
1.442 + && !(flags & TCL_GLOBAL_ONLY)
1.443 + /* careful: an undefined ns variable could
1.444 + * be hiding a valid global reference. */
1.445 + && !(varPtr->flags & VAR_UNDEFINED))));
1.446 + if (useReference && (varPtr->hPtr != NULL)) {
1.447 + /*
1.448 + * A straight global or namespace reference, use it. It isn't
1.449 + * so simple to deal with 'implicit' namespace references, i.e.,
1.450 + * those where the reference could be to either a namespace
1.451 + * or a global variable. Those we lookup again.
1.452 + *
1.453 + * If (varPtr->hPtr == NULL), this might be a reference to a
1.454 + * variable in a deleted namespace, kept alive by e.g. part1Ptr.
1.455 + * We could conceivably be so unlucky that a new namespace was
1.456 + * created at the same address as the deleted one, so to be
1.457 + * safe we test for a valid hPtr.
1.458 + */
1.459 + goto donePart1;
1.460 + }
1.461 + goto doneParsing;
1.462 + }
1.463 +
1.464 + doParse:
1.465 + if (!parsed && (*(part1 + len1 - 1) == ')')) {
1.466 + /*
1.467 + * part1Ptr is possibly an unparsed array element.
1.468 + */
1.469 + register int i;
1.470 + char *newPart2;
1.471 + len2 = -1;
1.472 + for (i = 0; i < len1; i++) {
1.473 + if (*(part1 + i) == '(') {
1.474 + if (part2 != NULL) {
1.475 + if (flags & TCL_LEAVE_ERR_MSG) {
1.476 + VarErrMsg(interp, part1, part2, msg, needArray);
1.477 + }
1.478 + }
1.479 +
1.480 + /*
1.481 + * part1Ptr points to an array element; first copy
1.482 + * the element name to a new string part2.
1.483 + */
1.484 +
1.485 + part2 = part1 + i + 1;
1.486 + len2 = len1 - i - 2;
1.487 + len1 = i;
1.488 +
1.489 + newPart2 = ckalloc((unsigned int) (len2+1));
1.490 + memcpy(newPart2, part2, (unsigned int) len2);
1.491 + *(newPart2+len2) = '\0';
1.492 + part2 = newPart2;
1.493 +
1.494 + /*
1.495 + * Free the internal rep of the original part1Ptr, now
1.496 + * renamed objPtr, and set it to tclParsedVarNameType.
1.497 + */
1.498 +
1.499 + objPtr = part1Ptr;
1.500 + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
1.501 + typePtr->freeIntRepProc(objPtr);
1.502 + }
1.503 + objPtr->typePtr = &tclParsedVarNameType;
1.504 +
1.505 + /*
1.506 + * Define a new string object to hold the new part1Ptr, i.e.,
1.507 + * the array name. Set the internal rep of objPtr, reset
1.508 + * typePtr and part1 to contain the references to the
1.509 + * array name.
1.510 + */
1.511 +
1.512 + part1Ptr = Tcl_NewStringObj(part1, len1);
1.513 + Tcl_IncrRefCount(part1Ptr);
1.514 +
1.515 + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) part1Ptr;
1.516 + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) part2;
1.517 +
1.518 + typePtr = part1Ptr->typePtr;
1.519 + part1 = TclGetString(part1Ptr);
1.520 + break;
1.521 + }
1.522 + }
1.523 + }
1.524 +
1.525 + doneParsing:
1.526 + /*
1.527 + * part1Ptr is not an array element; look it up, and convert
1.528 + * it to one of the cached types if possible.
1.529 + */
1.530 +
1.531 + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
1.532 + typePtr->freeIntRepProc(part1Ptr);
1.533 + part1Ptr->typePtr = NULL;
1.534 + }
1.535 +
1.536 + varPtr = TclLookupSimpleVar(interp, part1, flags,
1.537 + createPart1, &errMsg, &index);
1.538 + if (varPtr == NULL) {
1.539 + if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
1.540 + VarErrMsg(interp, part1, part2, msg, errMsg);
1.541 + }
1.542 + return NULL;
1.543 + }
1.544 +
1.545 + /*
1.546 + * Cache the newly found variable if possible.
1.547 + */
1.548 +
1.549 + if (index >= 0) {
1.550 + /*
1.551 + * An indexed local variable.
1.552 + */
1.553 +
1.554 + Proc *procPtr = ((Interp *) interp)->varFramePtr->procPtr;
1.555 +
1.556 + part1Ptr->typePtr = &tclLocalVarNameType;
1.557 + procPtr->refCount++;
1.558 + part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
1.559 + part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) index;
1.560 +#if 0
1.561 + /*
1.562 + * TEMPORARYLY DISABLED tclNsVarNameType
1.563 + *
1.564 + * This optimisation will hopefully be turned back on soon.
1.565 + * Miguel Sofer, 2004-05-22
1.566 + */
1.567 +
1.568 + } else if (index > -3) {
1.569 + /*
1.570 + * A cacheable namespace or global variable.
1.571 + */
1.572 + Namespace *nsPtr;
1.573 +
1.574 + nsPtr = ((index == -1)? iPtr->globalNsPtr : varFramePtr->nsPtr);
1.575 + varPtr->refCount++;
1.576 + part1Ptr->typePtr = &tclNsVarNameType;
1.577 + part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr;
1.578 + part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
1.579 +#endif
1.580 + } else {
1.581 + /*
1.582 + * At least mark part1Ptr as already parsed.
1.583 + */
1.584 + part1Ptr->typePtr = &tclParsedVarNameType;
1.585 + part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
1.586 + part1Ptr->internalRep.twoPtrValue.ptr2 = NULL;
1.587 + }
1.588 +
1.589 + donePart1:
1.590 +#if 0
1.591 + if (varPtr == NULL) {
1.592 + if (flags & TCL_LEAVE_ERR_MSG) {
1.593 + part1 = TclGetString(part1Ptr);
1.594 + VarErrMsg(interp, part1, part2, msg,
1.595 + "Cached variable reference is NULL.");
1.596 + }
1.597 + return NULL;
1.598 + }
1.599 +#endif
1.600 + while (TclIsVarLink(varPtr)) {
1.601 + varPtr = varPtr->value.linkPtr;
1.602 + }
1.603 +
1.604 + if (part2 != NULL) {
1.605 + /*
1.606 + * Array element sought: look it up.
1.607 + */
1.608 +
1.609 + part1 = TclGetString(part1Ptr);
1.610 + *arrayPtrPtr = varPtr;
1.611 + varPtr = TclLookupArrayElement(interp, part1, part2,
1.612 + flags, msg, createPart1, createPart2, varPtr);
1.613 + }
1.614 + return varPtr;
1.615 +}
1.616 +
1.617 +/*
1.618 + * This flag bit should not interfere with TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
1.619 + * or TCL_LEAVE_ERR_MSG; it signals that the variable lookup is performed for
1.620 + * upvar (or similar) purposes, with slightly different rules:
1.621 + * - Bug #696893 - variable is either proc-local or in the current
1.622 + * namespace; never follow the second (global) resolution path
1.623 + * - Bug #631741 - do not use special namespace or interp resolvers
1.624 + */
1.625 +#define LOOKUP_FOR_UPVAR 0x40000
1.626 +
1.627 +/*
1.628 + *----------------------------------------------------------------------
1.629 + *
1.630 + * TclLookupSimpleVar --
1.631 + *
1.632 + * This procedure is used by to locate a simple variable (i.e., not
1.633 + * an array element) given its name.
1.634 + *
1.635 + * Results:
1.636 + * The return value is a pointer to the variable structure indicated by
1.637 + * varName, or NULL if the variable couldn't be found. If the variable
1.638 + * can't be found and create is 1, a new as-yet-undefined (VAR_UNDEFINED)
1.639 + * variable structure is created, entered into a hash table, and returned.
1.640 + *
1.641 + * If the current CallFrame corresponds to a proc and the variable found is
1.642 + * one of the compiledLocals, its index is placed in *indexPtr. Otherwise,
1.643 + * *indexPtr will be set to (according to the needs of TclObjLookupVar):
1.644 + * -1 a global reference
1.645 + * -2 a reference to a namespace variable
1.646 + * -3 a non-cachable reference, i.e., one of:
1.647 + * . non-indexed local var
1.648 + * . a reference of unknown origin;
1.649 + * . resolution by a namespace or interp resolver
1.650 + *
1.651 + * If the variable isn't found and creation wasn't specified, or some
1.652 + * other error occurs, NULL is returned and the corresponding error
1.653 + * message is left in *errMsgPtr.
1.654 + *
1.655 + * Note: it's possible for the variable returned to be VAR_UNDEFINED
1.656 + * even if create is 1 (this only causes the hash table entry to be
1.657 + * created). For example, the variable might be a global that has been
1.658 + * unset but is still referenced by a procedure, or a variable that has
1.659 + * been unset but it only being kept in existence (if VAR_UNDEFINED) by
1.660 + * a trace.
1.661 + *
1.662 + * Side effects:
1.663 + * A new hashtable entry may be created if create is 1.
1.664 + *
1.665 + *----------------------------------------------------------------------
1.666 + */
1.667 +
1.668 +Var *
1.669 +TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr)
1.670 + Tcl_Interp *interp; /* Interpreter to use for lookup. */
1.671 + CONST char *varName; /* This is a simple variable name that could
1.672 + * representa scalar or an array. */
1.673 + int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
1.674 + * LOOKUP_FOR_UPVAR and TCL_LEAVE_ERR_MSG bits
1.675 + * matter. */
1.676 + CONST int create; /* If 1, create hash table entry for varname,
1.677 + * if it doesn't already exist. If 0, return
1.678 + * error if it doesn't exist. */
1.679 + CONST char **errMsgPtr;
1.680 + int *indexPtr;
1.681 +{
1.682 + Interp *iPtr = (Interp *) interp;
1.683 + CallFrame *varFramePtr = iPtr->varFramePtr;
1.684 + /* Points to the procedure call frame whose
1.685 + * variables are currently in use. Same as
1.686 + * the current procedure's frame, if any,
1.687 + * unless an "uplevel" is executing. */
1.688 + Tcl_HashTable *tablePtr; /* Points to the hashtable, if any, in which
1.689 + * to look up the variable. */
1.690 + Tcl_Var var; /* Used to search for global names. */
1.691 + Var *varPtr; /* Points to the Var structure returned for
1.692 + * the variable. */
1.693 + Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
1.694 + ResolverScheme *resPtr;
1.695 + Tcl_HashEntry *hPtr;
1.696 + int new, i, result;
1.697 +
1.698 + varPtr = NULL;
1.699 + varNsPtr = NULL; /* set non-NULL if a nonlocal variable */
1.700 + *indexPtr = -3;
1.701 +
1.702 + if ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) {
1.703 + cxtNsPtr = iPtr->globalNsPtr;
1.704 + } else {
1.705 + cxtNsPtr = iPtr->varFramePtr->nsPtr;
1.706 + }
1.707 +
1.708 + /*
1.709 + * If this namespace has a variable resolver, then give it first
1.710 + * crack at the variable resolution. It may return a Tcl_Var
1.711 + * value, it may signal to continue onward, or it may signal
1.712 + * an error.
1.713 + */
1.714 +
1.715 + if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL)
1.716 + && !(flags & LOOKUP_FOR_UPVAR)) {
1.717 + resPtr = iPtr->resolverPtr;
1.718 +
1.719 + if (cxtNsPtr->varResProc) {
1.720 + result = (*cxtNsPtr->varResProc)(interp, varName,
1.721 + (Tcl_Namespace *) cxtNsPtr, flags, &var);
1.722 + } else {
1.723 + result = TCL_CONTINUE;
1.724 + }
1.725 +
1.726 + while (result == TCL_CONTINUE && resPtr) {
1.727 + if (resPtr->varResProc) {
1.728 + result = (*resPtr->varResProc)(interp, varName,
1.729 + (Tcl_Namespace *) cxtNsPtr, flags, &var);
1.730 + }
1.731 + resPtr = resPtr->nextPtr;
1.732 + }
1.733 +
1.734 + if (result == TCL_OK) {
1.735 + varPtr = (Var *) var;
1.736 + return varPtr;
1.737 + } else if (result != TCL_CONTINUE) {
1.738 + return NULL;
1.739 + }
1.740 + }
1.741 +
1.742 + /*
1.743 + * Look up varName. Look it up as either a namespace variable or as a
1.744 + * local variable in a procedure call frame (varFramePtr).
1.745 + * Interpret varName as a namespace variable if:
1.746 + * 1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag,
1.747 + * 2) there is no active frame (we're at the global :: scope),
1.748 + * 3) the active frame was pushed to define the namespace context
1.749 + * for a "namespace eval" or "namespace inscope" command,
1.750 + * 4) the name has namespace qualifiers ("::"s).
1.751 + * Otherwise, if varName is a local variable, search first in the
1.752 + * frame's array of compiler-allocated local variables, then in its
1.753 + * hashtable for runtime-created local variables.
1.754 + *
1.755 + * If create and the variable isn't found, create the variable and,
1.756 + * if necessary, create varFramePtr's local var hashtable.
1.757 + */
1.758 +
1.759 + if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0)
1.760 + || (varFramePtr == NULL)
1.761 + || !varFramePtr->isProcCallFrame
1.762 + || (strstr(varName, "::") != NULL)) {
1.763 + CONST char *tail;
1.764 + int lookGlobal;
1.765 +
1.766 + lookGlobal = (flags & TCL_GLOBAL_ONLY)
1.767 + || (cxtNsPtr == iPtr->globalNsPtr)
1.768 + || ((*varName == ':') && (*(varName+1) == ':'));
1.769 + if (lookGlobal) {
1.770 + *indexPtr = -1;
1.771 + flags = (flags | TCL_GLOBAL_ONLY) & ~(TCL_NAMESPACE_ONLY|LOOKUP_FOR_UPVAR);
1.772 + } else {
1.773 + if (flags & LOOKUP_FOR_UPVAR) {
1.774 + flags = (flags | TCL_NAMESPACE_ONLY) & ~LOOKUP_FOR_UPVAR;
1.775 + }
1.776 + if (flags & TCL_NAMESPACE_ONLY) {
1.777 + *indexPtr = -2;
1.778 + }
1.779 + }
1.780 +
1.781 + /*
1.782 + * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable,
1.783 + * or otherwise generate our own error!
1.784 + */
1.785 + var = Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr,
1.786 + flags & ~TCL_LEAVE_ERR_MSG);
1.787 + if (var != (Tcl_Var) NULL) {
1.788 + varPtr = (Var *) var;
1.789 + }
1.790 + if (varPtr == NULL) {
1.791 + if (create) { /* var wasn't found so create it */
1.792 + TclGetNamespaceForQualName(interp, varName, cxtNsPtr,
1.793 + flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
1.794 + if (varNsPtr == NULL) {
1.795 + *errMsgPtr = badNamespace;
1.796 + return NULL;
1.797 + }
1.798 + if (tail == NULL) {
1.799 + *errMsgPtr = missingName;
1.800 + return NULL;
1.801 + }
1.802 + hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new);
1.803 + varPtr = NewVar();
1.804 + Tcl_SetHashValue(hPtr, varPtr);
1.805 + varPtr->hPtr = hPtr;
1.806 + varPtr->nsPtr = varNsPtr;
1.807 + if ((lookGlobal) || (varNsPtr == NULL)) {
1.808 + /*
1.809 + * The variable was created starting from the global
1.810 + * namespace: a global reference is returned even if
1.811 + * it wasn't explicitly requested.
1.812 + */
1.813 + *indexPtr = -1;
1.814 + } else {
1.815 + *indexPtr = -2;
1.816 + }
1.817 + } else { /* var wasn't found and not to create it */
1.818 + *errMsgPtr = noSuchVar;
1.819 + return NULL;
1.820 + }
1.821 + }
1.822 + } else { /* local var: look in frame varFramePtr */
1.823 + Proc *procPtr = varFramePtr->procPtr;
1.824 + int localCt = procPtr->numCompiledLocals;
1.825 + CompiledLocal *localPtr = procPtr->firstLocalPtr;
1.826 + Var *localVarPtr = varFramePtr->compiledLocals;
1.827 + int varNameLen = strlen(varName);
1.828 +
1.829 + for (i = 0; i < localCt; i++) {
1.830 + if (!TclIsVarTemporary(localPtr)) {
1.831 + register char *localName = localVarPtr->name;
1.832 + if ((varName[0] == localName[0])
1.833 + && (varNameLen == localPtr->nameLength)
1.834 + && (strcmp(varName, localName) == 0)) {
1.835 + *indexPtr = i;
1.836 + return localVarPtr;
1.837 + }
1.838 + }
1.839 + localVarPtr++;
1.840 + localPtr = localPtr->nextPtr;
1.841 + }
1.842 + tablePtr = varFramePtr->varTablePtr;
1.843 + if (create) {
1.844 + if (tablePtr == NULL) {
1.845 + tablePtr = (Tcl_HashTable *)
1.846 + ckalloc(sizeof(Tcl_HashTable));
1.847 + Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
1.848 + varFramePtr->varTablePtr = tablePtr;
1.849 + }
1.850 + hPtr = Tcl_CreateHashEntry(tablePtr, varName, &new);
1.851 + if (new) {
1.852 + varPtr = NewVar();
1.853 + Tcl_SetHashValue(hPtr, varPtr);
1.854 + varPtr->hPtr = hPtr;
1.855 + varPtr->nsPtr = NULL; /* a local variable */
1.856 + } else {
1.857 + varPtr = (Var *) Tcl_GetHashValue(hPtr);
1.858 + }
1.859 + } else {
1.860 + hPtr = NULL;
1.861 + if (tablePtr != NULL) {
1.862 + hPtr = Tcl_FindHashEntry(tablePtr, varName);
1.863 + }
1.864 + if (hPtr == NULL) {
1.865 + *errMsgPtr = noSuchVar;
1.866 + return NULL;
1.867 + }
1.868 + varPtr = (Var *) Tcl_GetHashValue(hPtr);
1.869 + }
1.870 + }
1.871 + return varPtr;
1.872 +}
1.873 +
1.874 +/*
1.875 + *----------------------------------------------------------------------
1.876 + *
1.877 + * TclLookupArrayElement --
1.878 + *
1.879 + * This procedure is used to locate a variable which is in an array's
1.880 + * hashtable given a pointer to the array's Var structure and the
1.881 + * element's name.
1.882 + *
1.883 + * Results:
1.884 + * The return value is a pointer to the variable structure , or NULL if
1.885 + * the variable couldn't be found.
1.886 + *
1.887 + * If arrayPtr points to a variable that isn't an array and createPart1
1.888 + * is 1, the corresponding variable will be converted to an array.
1.889 + * Otherwise, NULL is returned and an error message is left in
1.890 + * the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
1.891 + *
1.892 + * If the variable is not found and createPart2 is 1, the variable is
1.893 + * created. Otherwise, NULL is returned and an error message is left in
1.894 + * the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
1.895 + *
1.896 + * Note: it's possible for the variable returned to be VAR_UNDEFINED
1.897 + * even if createPart1 or createPart2 are 1 (these only cause the hash
1.898 + * table entry or array to be created). For example, the variable might
1.899 + * be a global that has been unset but is still referenced by a
1.900 + * procedure, or a variable that has been unset but it only being kept
1.901 + * in existence (if VAR_UNDEFINED) by a trace.
1.902 + *
1.903 + * Side effects:
1.904 + * The variable at arrayPtr may be converted to be an array if
1.905 + * createPart1 is 1. A new hashtable entry may be created if createPart2
1.906 + * is 1.
1.907 + *
1.908 + *----------------------------------------------------------------------
1.909 + */
1.910 +
1.911 +Var *
1.912 +TclLookupArrayElement(interp, arrayName, elName, flags, msg, createArray, createElem, arrayPtr)
1.913 + Tcl_Interp *interp; /* Interpreter to use for lookup. */
1.914 + CONST char *arrayName; /* This is the name of the array. */
1.915 + CONST char *elName; /* Name of element within array. */
1.916 + CONST int flags; /* Only TCL_LEAVE_ERR_MSG bit matters. */
1.917 + CONST char *msg; /* Verb to use in error messages, e.g.
1.918 + * "read" or "set". Only needed if
1.919 + * TCL_LEAVE_ERR_MSG is set in flags. */
1.920 + CONST int createArray; /* If 1, transform arrayName to be an array
1.921 + * if it isn't one yet and the transformation
1.922 + * is possible. If 0, return error if it
1.923 + * isn't already an array. */
1.924 + CONST int createElem; /* If 1, create hash table entry for the
1.925 + * element, if it doesn't already exist. If
1.926 + * 0, return error if it doesn't exist. */
1.927 + Var *arrayPtr; /* Pointer to the array's Var structure. */
1.928 +{
1.929 + Tcl_HashEntry *hPtr;
1.930 + int new;
1.931 + Var *varPtr;
1.932 +
1.933 + /*
1.934 + * We're dealing with an array element. Make sure the variable is an
1.935 + * array and look up the element (create the element if desired).
1.936 + */
1.937 +
1.938 + if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) {
1.939 + if (!createArray) {
1.940 + if (flags & TCL_LEAVE_ERR_MSG) {
1.941 + VarErrMsg(interp, arrayName, elName, msg, noSuchVar);
1.942 + }
1.943 + return NULL;
1.944 + }
1.945 +
1.946 + /*
1.947 + * Make sure we are not resurrecting a namespace variable from a
1.948 + * deleted namespace!
1.949 + */
1.950 + if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) {
1.951 + if (flags & TCL_LEAVE_ERR_MSG) {
1.952 + VarErrMsg(interp, arrayName, elName, msg, danglingVar);
1.953 + }
1.954 + return NULL;
1.955 + }
1.956 +
1.957 + TclSetVarArray(arrayPtr);
1.958 + TclClearVarUndefined(arrayPtr);
1.959 + arrayPtr->value.tablePtr =
1.960 + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
1.961 + Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS);
1.962 + } else if (!TclIsVarArray(arrayPtr)) {
1.963 + if (flags & TCL_LEAVE_ERR_MSG) {
1.964 + VarErrMsg(interp, arrayName, elName, msg, needArray);
1.965 + }
1.966 + return NULL;
1.967 + }
1.968 +
1.969 + if (createElem) {
1.970 + hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elName, &new);
1.971 + if (new) {
1.972 + if (arrayPtr->searchPtr != NULL) {
1.973 + DeleteSearches(arrayPtr);
1.974 + }
1.975 + varPtr = NewVar();
1.976 + Tcl_SetHashValue(hPtr, varPtr);
1.977 + varPtr->hPtr = hPtr;
1.978 + varPtr->nsPtr = arrayPtr->nsPtr;
1.979 + TclSetVarArrayElement(varPtr);
1.980 + }
1.981 + } else {
1.982 + hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr, elName);
1.983 + if (hPtr == NULL) {
1.984 + if (flags & TCL_LEAVE_ERR_MSG) {
1.985 + VarErrMsg(interp, arrayName, elName, msg, noSuchElement);
1.986 + }
1.987 + return NULL;
1.988 + }
1.989 + }
1.990 + return (Var *) Tcl_GetHashValue(hPtr);
1.991 +}
1.992 +
1.993 +/*
1.994 + *----------------------------------------------------------------------
1.995 + *
1.996 + * Tcl_GetVar --
1.997 + *
1.998 + * Return the value of a Tcl variable as a string.
1.999 + *
1.1000 + * Results:
1.1001 + * The return value points to the current value of varName as a string.
1.1002 + * If the variable is not defined or can't be read because of a clash
1.1003 + * in array usage then a NULL pointer is returned and an error message
1.1004 + * is left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set.
1.1005 + * Note: the return value is only valid up until the next change to the
1.1006 + * variable; if you depend on the value lasting longer than that, then
1.1007 + * make yourself a private copy.
1.1008 + *
1.1009 + * Side effects:
1.1010 + * None.
1.1011 + *
1.1012 + *----------------------------------------------------------------------
1.1013 + */
1.1014 +
1.1015 +EXPORT_C CONST char *
1.1016 +Tcl_GetVar(interp, varName, flags)
1.1017 + Tcl_Interp *interp; /* Command interpreter in which varName is
1.1018 + * to be looked up. */
1.1019 + CONST char *varName; /* Name of a variable in interp. */
1.1020 + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
1.1021 + * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
1.1022 + * bits. */
1.1023 +{
1.1024 + return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
1.1025 +}
1.1026 +
1.1027 +/*
1.1028 + *----------------------------------------------------------------------
1.1029 + *
1.1030 + * Tcl_GetVar2 --
1.1031 + *
1.1032 + * Return the value of a Tcl variable as a string, given a two-part
1.1033 + * name consisting of array name and element within array.
1.1034 + *
1.1035 + * Results:
1.1036 + * The return value points to the current value of the variable given
1.1037 + * by part1 and part2 as a string. If the specified variable doesn't
1.1038 + * exist, or if there is a clash in array usage, then NULL is returned
1.1039 + * and a message will be left in the interp's result if the
1.1040 + * TCL_LEAVE_ERR_MSG flag is set. Note: the return value is only valid
1.1041 + * up until the next change to the variable; if you depend on the value
1.1042 + * lasting longer than that, then make yourself a private copy.
1.1043 + *
1.1044 + * Side effects:
1.1045 + * None.
1.1046 + *
1.1047 + *----------------------------------------------------------------------
1.1048 + */
1.1049 +
1.1050 +EXPORT_C CONST char *
1.1051 +Tcl_GetVar2(interp, part1, part2, flags)
1.1052 + Tcl_Interp *interp; /* Command interpreter in which variable is
1.1053 + * to be looked up. */
1.1054 + CONST char *part1; /* Name of an array (if part2 is non-NULL)
1.1055 + * or the name of a variable. */
1.1056 + CONST char *part2; /* If non-NULL, gives the name of an element
1.1057 + * in the array part1. */
1.1058 + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
1.1059 + * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG
1.1060 + * bits. */
1.1061 +{
1.1062 + Tcl_Obj *objPtr;
1.1063 +
1.1064 + objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags);
1.1065 + if (objPtr == NULL) {
1.1066 + return NULL;
1.1067 + }
1.1068 + return TclGetString(objPtr);
1.1069 +}
1.1070 +
1.1071 +/*
1.1072 + *----------------------------------------------------------------------
1.1073 + *
1.1074 + * Tcl_GetVar2Ex --
1.1075 + *
1.1076 + * Return the value of a Tcl variable as a Tcl object, given a
1.1077 + * two-part name consisting of array name and element within array.
1.1078 + *
1.1079 + * Results:
1.1080 + * The return value points to the current object value of the variable
1.1081 + * given by part1Ptr and part2Ptr. If the specified variable doesn't
1.1082 + * exist, or if there is a clash in array usage, then NULL is returned
1.1083 + * and a message will be left in the interpreter's result if the
1.1084 + * TCL_LEAVE_ERR_MSG flag is set.
1.1085 + *
1.1086 + * Side effects:
1.1087 + * The ref count for the returned object is _not_ incremented to
1.1088 + * reflect the returned reference; if you want to keep a reference to
1.1089 + * the object you must increment its ref count yourself.
1.1090 + *
1.1091 + *----------------------------------------------------------------------
1.1092 + */
1.1093 +
1.1094 +EXPORT_C Tcl_Obj *
1.1095 +Tcl_GetVar2Ex(interp, part1, part2, flags)
1.1096 + Tcl_Interp *interp; /* Command interpreter in which variable is
1.1097 + * to be looked up. */
1.1098 + CONST char *part1; /* Name of an array (if part2 is non-NULL)
1.1099 + * or the name of a variable. */
1.1100 + CONST char *part2; /* If non-NULL, gives the name of an element
1.1101 + * in the array part1. */
1.1102 + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
1.1103 + * and TCL_LEAVE_ERR_MSG bits. */
1.1104 +{
1.1105 + Var *varPtr, *arrayPtr;
1.1106 +
1.1107 + /* Filter to pass through only the flags this interface supports. */
1.1108 + flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
1.1109 + varPtr = TclLookupVar(interp, part1, part2, flags, "read",
1.1110 + /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
1.1111 + if (varPtr == NULL) {
1.1112 + return NULL;
1.1113 + }
1.1114 +
1.1115 + return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
1.1116 +}
1.1117 +
1.1118 +/*
1.1119 + *----------------------------------------------------------------------
1.1120 + *
1.1121 + * Tcl_ObjGetVar2 --
1.1122 + *
1.1123 + * Return the value of a Tcl variable as a Tcl object, given a
1.1124 + * two-part name consisting of array name and element within array.
1.1125 + *
1.1126 + * Results:
1.1127 + * The return value points to the current object value of the variable
1.1128 + * given by part1Ptr and part2Ptr. If the specified variable doesn't
1.1129 + * exist, or if there is a clash in array usage, then NULL is returned
1.1130 + * and a message will be left in the interpreter's result if the
1.1131 + * TCL_LEAVE_ERR_MSG flag is set.
1.1132 + *
1.1133 + * Side effects:
1.1134 + * The ref count for the returned object is _not_ incremented to
1.1135 + * reflect the returned reference; if you want to keep a reference to
1.1136 + * the object you must increment its ref count yourself.
1.1137 + *
1.1138 + *----------------------------------------------------------------------
1.1139 + */
1.1140 +
1.1141 +EXPORT_C Tcl_Obj *
1.1142 +Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags)
1.1143 + Tcl_Interp *interp; /* Command interpreter in which variable is
1.1144 + * to be looked up. */
1.1145 + register Tcl_Obj *part1Ptr; /* Points to an object holding the name of
1.1146 + * an array (if part2 is non-NULL) or the
1.1147 + * name of a variable. */
1.1148 + register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
1.1149 + * the name of an element in the array
1.1150 + * part1Ptr. */
1.1151 + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY and
1.1152 + * TCL_LEAVE_ERR_MSG bits. */
1.1153 +{
1.1154 + Var *varPtr, *arrayPtr;
1.1155 + char *part1, *part2;
1.1156 +
1.1157 + part1 = Tcl_GetString(part1Ptr);
1.1158 + part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr));
1.1159 +
1.1160 + /* Filter to pass through only the flags this interface supports. */
1.1161 + flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
1.1162 + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
1.1163 + /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
1.1164 + if (varPtr == NULL) {
1.1165 + return NULL;
1.1166 + }
1.1167 +
1.1168 + return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
1.1169 +}
1.1170 +
1.1171 +/*
1.1172 + *----------------------------------------------------------------------
1.1173 + *
1.1174 + * TclPtrGetVar --
1.1175 + *
1.1176 + * Return the value of a Tcl variable as a Tcl object, given the
1.1177 + * pointers to the variable's (and possibly containing array's)
1.1178 + * VAR structure.
1.1179 + *
1.1180 + * Results:
1.1181 + * The return value points to the current object value of the variable
1.1182 + * given by varPtr. If the specified variable doesn't exist, or if there
1.1183 + * is a clash in array usage, then NULL is returned and a message will be
1.1184 + * left in the interpreter's result if the TCL_LEAVE_ERR_MSG flag is set.
1.1185 + *
1.1186 + * Side effects:
1.1187 + * The ref count for the returned object is _not_ incremented to
1.1188 + * reflect the returned reference; if you want to keep a reference to
1.1189 + * the object you must increment its ref count yourself.
1.1190 + *
1.1191 + *----------------------------------------------------------------------
1.1192 + */
1.1193 +
1.1194 +Tcl_Obj *
1.1195 +TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags)
1.1196 + Tcl_Interp *interp; /* Command interpreter in which variable is
1.1197 + * to be looked up. */
1.1198 + register Var *varPtr; /* The variable to be read.*/
1.1199 + Var *arrayPtr; /* NULL for scalar variables, pointer to
1.1200 + * the containing array otherwise. */
1.1201 + CONST char *part1; /* Name of an array (if part2 is non-NULL)
1.1202 + * or the name of a variable. */
1.1203 + CONST char *part2; /* If non-NULL, gives the name of an element
1.1204 + * in the array part1. */
1.1205 + CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
1.1206 + * and TCL_LEAVE_ERR_MSG bits. */
1.1207 +{
1.1208 + Interp *iPtr = (Interp *) interp;
1.1209 + CONST char *msg;
1.1210 +
1.1211 + /*
1.1212 + * Invoke any traces that have been set for the variable.
1.1213 + */
1.1214 +
1.1215 + if ((varPtr->tracePtr != NULL)
1.1216 + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
1.1217 + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
1.1218 + (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY))
1.1219 + | TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
1.1220 + goto errorReturn;
1.1221 + }
1.1222 + }
1.1223 +
1.1224 + /*
1.1225 + * Return the element if it's an existing scalar variable.
1.1226 + */
1.1227 +
1.1228 + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
1.1229 + return varPtr->value.objPtr;
1.1230 + }
1.1231 +
1.1232 + if (flags & TCL_LEAVE_ERR_MSG) {
1.1233 + if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL)
1.1234 + && !TclIsVarUndefined(arrayPtr)) {
1.1235 + msg = noSuchElement;
1.1236 + } else if (TclIsVarArray(varPtr)) {
1.1237 + msg = isArray;
1.1238 + } else {
1.1239 + msg = noSuchVar;
1.1240 + }
1.1241 + VarErrMsg(interp, part1, part2, "read", msg);
1.1242 + }
1.1243 +
1.1244 + /*
1.1245 + * An error. If the variable doesn't exist anymore and no-one's using
1.1246 + * it, then free up the relevant structures and hash table entries.
1.1247 + */
1.1248 +
1.1249 + errorReturn:
1.1250 + if (TclIsVarUndefined(varPtr)) {
1.1251 + CleanupVar(varPtr, arrayPtr);
1.1252 + }
1.1253 + return NULL;
1.1254 +}
1.1255 +
1.1256 +/*
1.1257 + *----------------------------------------------------------------------
1.1258 + *
1.1259 + * Tcl_SetObjCmd --
1.1260 + *
1.1261 + * This procedure is invoked to process the "set" Tcl command.
1.1262 + * See the user documentation for details on what it does.
1.1263 + *
1.1264 + * Results:
1.1265 + * A standard Tcl result value.
1.1266 + *
1.1267 + * Side effects:
1.1268 + * A variable's value may be changed.
1.1269 + *
1.1270 + *----------------------------------------------------------------------
1.1271 + */
1.1272 +
1.1273 + /* ARGSUSED */
1.1274 +int
1.1275 +Tcl_SetObjCmd(dummy, interp, objc, objv)
1.1276 + ClientData dummy; /* Not used. */
1.1277 + register Tcl_Interp *interp; /* Current interpreter. */
1.1278 + int objc; /* Number of arguments. */
1.1279 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1280 +{
1.1281 + Tcl_Obj *varValueObj;
1.1282 +
1.1283 + if (objc == 2) {
1.1284 + varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
1.1285 + if (varValueObj == NULL) {
1.1286 + return TCL_ERROR;
1.1287 + }
1.1288 + Tcl_SetObjResult(interp, varValueObj);
1.1289 + return TCL_OK;
1.1290 + } else if (objc == 3) {
1.1291 +
1.1292 + varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2],
1.1293 + TCL_LEAVE_ERR_MSG);
1.1294 + if (varValueObj == NULL) {
1.1295 + return TCL_ERROR;
1.1296 + }
1.1297 + Tcl_SetObjResult(interp, varValueObj);
1.1298 + return TCL_OK;
1.1299 + } else {
1.1300 + Tcl_WrongNumArgs(interp, 1, objv, "varName ?newValue?");
1.1301 + return TCL_ERROR;
1.1302 + }
1.1303 +}
1.1304 +
1.1305 +/*
1.1306 + *----------------------------------------------------------------------
1.1307 + *
1.1308 + * Tcl_SetVar --
1.1309 + *
1.1310 + * Change the value of a variable.
1.1311 + *
1.1312 + * Results:
1.1313 + * Returns a pointer to the malloc'ed string which is the character
1.1314 + * representation of the variable's new value. The caller must not
1.1315 + * modify this string. If the write operation was disallowed then NULL
1.1316 + * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then an
1.1317 + * explanatory message will be left in the interp's result. Note that the
1.1318 + * returned string may not be the same as newValue; this is because
1.1319 + * variable traces may modify the variable's value.
1.1320 + *
1.1321 + * Side effects:
1.1322 + * If varName is defined as a local or global variable in interp,
1.1323 + * its value is changed to newValue. If varName isn't currently
1.1324 + * defined, then a new global variable by that name is created.
1.1325 + *
1.1326 + *----------------------------------------------------------------------
1.1327 + */
1.1328 +
1.1329 +EXPORT_C CONST char *
1.1330 +Tcl_SetVar(interp, varName, newValue, flags)
1.1331 + Tcl_Interp *interp; /* Command interpreter in which varName is
1.1332 + * to be looked up. */
1.1333 + CONST char *varName; /* Name of a variable in interp. */
1.1334 + CONST char *newValue; /* New value for varName. */
1.1335 + int flags; /* Various flags that tell how to set value:
1.1336 + * any of TCL_GLOBAL_ONLY,
1.1337 + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
1.1338 + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
1.1339 +{
1.1340 + return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
1.1341 +}
1.1342 +
1.1343 +/*
1.1344 + *----------------------------------------------------------------------
1.1345 + *
1.1346 + * Tcl_SetVar2 --
1.1347 + *
1.1348 + * Given a two-part variable name, which may refer either to a
1.1349 + * scalar variable or an element of an array, change the value
1.1350 + * of the variable. If the named scalar or array or element
1.1351 + * doesn't exist then create one.
1.1352 + *
1.1353 + * Results:
1.1354 + * Returns a pointer to the malloc'ed string which is the character
1.1355 + * representation of the variable's new value. The caller must not
1.1356 + * modify this string. If the write operation was disallowed because an
1.1357 + * array was expected but not found (or vice versa), then NULL is
1.1358 + * returned; if the TCL_LEAVE_ERR_MSG flag is set, then an explanatory
1.1359 + * message will be left in the interp's result. Note that the returned
1.1360 + * string may not be the same as newValue; this is because variable
1.1361 + * traces may modify the variable's value.
1.1362 + *
1.1363 + * Side effects:
1.1364 + * The value of the given variable is set. If either the array
1.1365 + * or the entry didn't exist then a new one is created.
1.1366 + *
1.1367 + *----------------------------------------------------------------------
1.1368 + */
1.1369 +
1.1370 +EXPORT_C CONST char *
1.1371 +Tcl_SetVar2(interp, part1, part2, newValue, flags)
1.1372 + Tcl_Interp *interp; /* Command interpreter in which variable is
1.1373 + * to be looked up. */
1.1374 + CONST char *part1; /* If part2 is NULL, this is name of scalar
1.1375 + * variable. Otherwise it is the name of
1.1376 + * an array. */
1.1377 + CONST char *part2; /* Name of an element within an array, or
1.1378 + * NULL. */
1.1379 + CONST char *newValue; /* New value for variable. */
1.1380 + int flags; /* Various flags that tell how to set value:
1.1381 + * any of TCL_GLOBAL_ONLY,
1.1382 + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
1.1383 + * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG */
1.1384 +{
1.1385 + register Tcl_Obj *valuePtr;
1.1386 + Tcl_Obj *varValuePtr;
1.1387 +
1.1388 + /*
1.1389 + * Create an object holding the variable's new value and use
1.1390 + * Tcl_SetVar2Ex to actually set the variable.
1.1391 + */
1.1392 +
1.1393 + valuePtr = Tcl_NewStringObj(newValue, -1);
1.1394 + Tcl_IncrRefCount(valuePtr);
1.1395 +
1.1396 + varValuePtr = Tcl_SetVar2Ex(interp, part1, part2, valuePtr, flags);
1.1397 + Tcl_DecrRefCount(valuePtr); /* done with the object */
1.1398 +
1.1399 + if (varValuePtr == NULL) {
1.1400 + return NULL;
1.1401 + }
1.1402 + return TclGetString(varValuePtr);
1.1403 +}
1.1404 +
1.1405 +/*
1.1406 + *----------------------------------------------------------------------
1.1407 + *
1.1408 + * Tcl_SetVar2Ex --
1.1409 + *
1.1410 + * Given a two-part variable name, which may refer either to a scalar
1.1411 + * variable or an element of an array, change the value of the variable
1.1412 + * to a new Tcl object value. If the named scalar or array or element
1.1413 + * doesn't exist then create one.
1.1414 + *
1.1415 + * Results:
1.1416 + * Returns a pointer to the Tcl_Obj holding the new value of the
1.1417 + * variable. If the write operation was disallowed because an array was
1.1418 + * expected but not found (or vice versa), then NULL is returned; if
1.1419 + * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
1.1420 + * be left in the interpreter's result. Note that the returned object
1.1421 + * may not be the same one referenced by newValuePtr; this is because
1.1422 + * variable traces may modify the variable's value.
1.1423 + *
1.1424 + * Side effects:
1.1425 + * The value of the given variable is set. If either the array or the
1.1426 + * entry didn't exist then a new variable is created.
1.1427 + *
1.1428 + * The reference count is decremented for any old value of the variable
1.1429 + * and incremented for its new value. If the new value for the variable
1.1430 + * is not the same one referenced by newValuePtr (perhaps as a result
1.1431 + * of a variable trace), then newValuePtr's ref count is left unchanged
1.1432 + * by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if
1.1433 + * we are appending it as a string value: that is, if "flags" includes
1.1434 + * TCL_APPEND_VALUE but not TCL_LIST_ELEMENT.
1.1435 + *
1.1436 + * The reference count for the returned object is _not_ incremented: if
1.1437 + * you want to keep a reference to the object you must increment its
1.1438 + * ref count yourself.
1.1439 + *
1.1440 + *----------------------------------------------------------------------
1.1441 + */
1.1442 +
1.1443 +EXPORT_C Tcl_Obj *
1.1444 +Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
1.1445 + Tcl_Interp *interp; /* Command interpreter in which variable is
1.1446 + * to be found. */
1.1447 + CONST char *part1; /* Name of an array (if part2 is non-NULL)
1.1448 + * or the name of a variable. */
1.1449 + CONST char *part2; /* If non-NULL, gives the name of an element
1.1450 + * in the array part1. */
1.1451 + Tcl_Obj *newValuePtr; /* New value for variable. */
1.1452 + int flags; /* Various flags that tell how to set value:
1.1453 + * any of TCL_GLOBAL_ONLY,
1.1454 + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
1.1455 + * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
1.1456 +{
1.1457 + Var *varPtr, *arrayPtr;
1.1458 +
1.1459 + /* Filter to pass through only the flags this interface supports. */
1.1460 + flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG
1.1461 + |TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
1.1462 + varPtr = TclLookupVar(interp, part1, part2, flags, "set",
1.1463 + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
1.1464 + if (varPtr == NULL) {
1.1465 + return NULL;
1.1466 + }
1.1467 +
1.1468 + return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
1.1469 + newValuePtr, flags);
1.1470 +}
1.1471 +
1.1472 +/*
1.1473 + *----------------------------------------------------------------------
1.1474 + *
1.1475 + * Tcl_ObjSetVar2 --
1.1476 + *
1.1477 + * This function is the same as Tcl_SetVar2Ex above, except the
1.1478 + * variable names are passed in Tcl object instead of strings.
1.1479 + *
1.1480 + * Results:
1.1481 + * Returns a pointer to the Tcl_Obj holding the new value of the
1.1482 + * variable. If the write operation was disallowed because an array was
1.1483 + * expected but not found (or vice versa), then NULL is returned; if
1.1484 + * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
1.1485 + * be left in the interpreter's result. Note that the returned object
1.1486 + * may not be the same one referenced by newValuePtr; this is because
1.1487 + * variable traces may modify the variable's value.
1.1488 + *
1.1489 + * Side effects:
1.1490 + * The value of the given variable is set. If either the array or the
1.1491 + * entry didn't exist then a new variable is created.
1.1492 + *
1.1493 + *----------------------------------------------------------------------
1.1494 + */
1.1495 +
1.1496 +EXPORT_C Tcl_Obj *
1.1497 +Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags)
1.1498 + Tcl_Interp *interp; /* Command interpreter in which variable is
1.1499 + * to be found. */
1.1500 + register Tcl_Obj *part1Ptr; /* Points to an object holding the name of
1.1501 + * an array (if part2 is non-NULL) or the
1.1502 + * name of a variable. */
1.1503 + register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
1.1504 + * the name of an element in the array
1.1505 + * part1Ptr. */
1.1506 + Tcl_Obj *newValuePtr; /* New value for variable. */
1.1507 + int flags; /* Various flags that tell how to set value:
1.1508 + * any of TCL_GLOBAL_ONLY,
1.1509 + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
1.1510 + * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */
1.1511 +{
1.1512 + Var *varPtr, *arrayPtr;
1.1513 + char *part1, *part2;
1.1514 +
1.1515 + part1 = TclGetString(part1Ptr);
1.1516 + part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr));
1.1517 +
1.1518 + /* Filter to pass through only the flags this interface supports. */
1.1519 + flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG
1.1520 + |TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
1.1521 + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set",
1.1522 + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
1.1523 + if (varPtr == NULL) {
1.1524 + return NULL;
1.1525 + }
1.1526 +
1.1527 + return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
1.1528 + newValuePtr, flags);
1.1529 +}
1.1530 +
1.1531 +
1.1532 +/*
1.1533 + *----------------------------------------------------------------------
1.1534 + *
1.1535 + * TclPtrSetVar --
1.1536 + *
1.1537 + * This function is the same as Tcl_SetVar2Ex above, except that
1.1538 + * it requires pointers to the variable's Var structs in addition
1.1539 + * to the variable names.
1.1540 + *
1.1541 + * Results:
1.1542 + * Returns a pointer to the Tcl_Obj holding the new value of the
1.1543 + * variable. If the write operation was disallowed because an array was
1.1544 + * expected but not found (or vice versa), then NULL is returned; if
1.1545 + * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
1.1546 + * be left in the interpreter's result. Note that the returned object
1.1547 + * may not be the same one referenced by newValuePtr; this is because
1.1548 + * variable traces may modify the variable's value.
1.1549 + *
1.1550 + * Side effects:
1.1551 + * The value of the given variable is set. If either the array or the
1.1552 + * entry didn't exist then a new variable is created.
1.1553 +
1.1554 + *
1.1555 + *----------------------------------------------------------------------
1.1556 + */
1.1557 +
1.1558 +Tcl_Obj *
1.1559 +TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags)
1.1560 + Tcl_Interp *interp; /* Command interpreter in which variable is
1.1561 + * to be looked up. */
1.1562 + register Var *varPtr;
1.1563 + Var *arrayPtr;
1.1564 + CONST char *part1; /* Name of an array (if part2 is non-NULL)
1.1565 + * or the name of a variable. */
1.1566 + CONST char *part2; /* If non-NULL, gives the name of an element
1.1567 + * in the array part1. */
1.1568 + Tcl_Obj *newValuePtr; /* New value for variable. */
1.1569 + CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
1.1570 + * and TCL_LEAVE_ERR_MSG bits. */
1.1571 +{
1.1572 + Interp *iPtr = (Interp *) interp;
1.1573 + Tcl_Obj *oldValuePtr;
1.1574 + Tcl_Obj *resultPtr = NULL;
1.1575 + int result;
1.1576 +
1.1577 + /*
1.1578 + * If the variable is in a hashtable and its hPtr field is NULL, then we
1.1579 + * may have an upvar to an array element where the array was deleted
1.1580 + * or an upvar to a namespace variable whose namespace was deleted.
1.1581 + * Generate an error (allowing the variable to be reset would screw up
1.1582 + * our storage allocation and is meaningless anyway).
1.1583 + */
1.1584 +
1.1585 + if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) {
1.1586 + if (flags & TCL_LEAVE_ERR_MSG) {
1.1587 + if (TclIsVarArrayElement(varPtr)) {
1.1588 + VarErrMsg(interp, part1, part2, "set", danglingElement);
1.1589 + } else {
1.1590 + VarErrMsg(interp, part1, part2, "set", danglingVar);
1.1591 + }
1.1592 + }
1.1593 + return NULL;
1.1594 + }
1.1595 +
1.1596 + /*
1.1597 + * It's an error to try to set an array variable itself.
1.1598 + */
1.1599 +
1.1600 + if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
1.1601 + if (flags & TCL_LEAVE_ERR_MSG) {
1.1602 + VarErrMsg(interp, part1, part2, "set", isArray);
1.1603 + }
1.1604 + return NULL;
1.1605 + }
1.1606 +
1.1607 + /*
1.1608 + * Invoke any read traces that have been set for the variable if it
1.1609 + * is requested; this is only done in the core by the INST_LAPPEND_*
1.1610 + * instructions.
1.1611 + */
1.1612 +
1.1613 + if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL)
1.1614 + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) {
1.1615 + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
1.1616 + TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
1.1617 + return NULL;
1.1618 + }
1.1619 + }
1.1620 +
1.1621 + /*
1.1622 + * Set the variable's new value. If appending, append the new value to
1.1623 + * the variable, either as a list element or as a string. Also, if
1.1624 + * appending, then if the variable's old value is unshared we can modify
1.1625 + * it directly, otherwise we must create a new copy to modify: this is
1.1626 + * "copy on write".
1.1627 + */
1.1628 +
1.1629 + if (flags & TCL_LIST_ELEMENT && !(flags & TCL_APPEND_VALUE)) {
1.1630 + TclSetVarUndefined(varPtr);
1.1631 + }
1.1632 + oldValuePtr = varPtr->value.objPtr;
1.1633 + if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) {
1.1634 + if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
1.1635 + Tcl_DecrRefCount(oldValuePtr); /* discard old value */
1.1636 + varPtr->value.objPtr = NULL;
1.1637 + oldValuePtr = NULL;
1.1638 + }
1.1639 + if (flags & TCL_LIST_ELEMENT) { /* append list element */
1.1640 + if (oldValuePtr == NULL) {
1.1641 + TclNewObj(oldValuePtr);
1.1642 + varPtr->value.objPtr = oldValuePtr;
1.1643 + Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
1.1644 + } else if (Tcl_IsShared(oldValuePtr)) {
1.1645 + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
1.1646 + Tcl_DecrRefCount(oldValuePtr);
1.1647 + oldValuePtr = varPtr->value.objPtr;
1.1648 + Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
1.1649 + }
1.1650 + result = Tcl_ListObjAppendElement(interp, oldValuePtr,
1.1651 + newValuePtr);
1.1652 + if (result != TCL_OK) {
1.1653 + return NULL;
1.1654 + }
1.1655 + } else { /* append string */
1.1656 + /*
1.1657 + * We append newValuePtr's bytes but don't change its ref count.
1.1658 + */
1.1659 +
1.1660 + if (oldValuePtr == NULL) {
1.1661 + varPtr->value.objPtr = newValuePtr;
1.1662 + Tcl_IncrRefCount(newValuePtr);
1.1663 + } else {
1.1664 + if (Tcl_IsShared(oldValuePtr)) { /* append to copy */
1.1665 + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
1.1666 + TclDecrRefCount(oldValuePtr);
1.1667 + oldValuePtr = varPtr->value.objPtr;
1.1668 + Tcl_IncrRefCount(oldValuePtr); /* since var is ref */
1.1669 + }
1.1670 + Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
1.1671 + }
1.1672 + }
1.1673 + } else if (newValuePtr != oldValuePtr) {
1.1674 + /*
1.1675 + * In this case we are replacing the value, so we don't need to
1.1676 + * do more than swap the objects.
1.1677 + */
1.1678 +
1.1679 + varPtr->value.objPtr = newValuePtr;
1.1680 + Tcl_IncrRefCount(newValuePtr); /* var is another ref */
1.1681 + if (oldValuePtr != NULL) {
1.1682 + TclDecrRefCount(oldValuePtr); /* discard old value */
1.1683 + }
1.1684 + }
1.1685 + TclSetVarScalar(varPtr);
1.1686 + TclClearVarUndefined(varPtr);
1.1687 + if (arrayPtr != NULL) {
1.1688 + TclClearVarUndefined(arrayPtr);
1.1689 + }
1.1690 +
1.1691 + /*
1.1692 + * Invoke any write traces for the variable.
1.1693 + */
1.1694 +
1.1695 + if ((varPtr->tracePtr != NULL)
1.1696 + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
1.1697 + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
1.1698 + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
1.1699 + | TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) {
1.1700 + goto cleanup;
1.1701 + }
1.1702 + }
1.1703 +
1.1704 + /*
1.1705 + * Return the variable's value unless the variable was changed in some
1.1706 + * gross way by a trace (e.g. it was unset and then recreated as an
1.1707 + * array).
1.1708 + */
1.1709 +
1.1710 + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
1.1711 + return varPtr->value.objPtr;
1.1712 + }
1.1713 +
1.1714 + /*
1.1715 + * A trace changed the value in some gross way. Return an empty string
1.1716 + * object.
1.1717 + */
1.1718 +
1.1719 + resultPtr = iPtr->emptyObjPtr;
1.1720 +
1.1721 + /*
1.1722 + * If the variable doesn't exist anymore and no-one's using it, then
1.1723 + * free up the relevant structures and hash table entries.
1.1724 + */
1.1725 +
1.1726 + cleanup:
1.1727 + if (TclIsVarUndefined(varPtr)) {
1.1728 + CleanupVar(varPtr, arrayPtr);
1.1729 + }
1.1730 + return resultPtr;
1.1731 +}
1.1732 +
1.1733 +/*
1.1734 + *----------------------------------------------------------------------
1.1735 + *
1.1736 + * TclIncrVar2 --
1.1737 + *
1.1738 + * Given a two-part variable name, which may refer either to a scalar
1.1739 + * variable or an element of an array, increment the Tcl object value
1.1740 + * of the variable by a specified amount.
1.1741 + *
1.1742 + * Results:
1.1743 + * Returns a pointer to the Tcl_Obj holding the new value of the
1.1744 + * variable. If the specified variable doesn't exist, or there is a
1.1745 + * clash in array usage, or an error occurs while executing variable
1.1746 + * traces, then NULL is returned and a message will be left in
1.1747 + * the interpreter's result.
1.1748 + *
1.1749 + * Side effects:
1.1750 + * The value of the given variable is incremented by the specified
1.1751 + * amount. If either the array or the entry didn't exist then a new
1.1752 + * variable is created. The ref count for the returned object is _not_
1.1753 + * incremented to reflect the returned reference; if you want to keep a
1.1754 + * reference to the object you must increment its ref count yourself.
1.1755 + *
1.1756 + *----------------------------------------------------------------------
1.1757 + */
1.1758 +
1.1759 +Tcl_Obj *
1.1760 +TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags)
1.1761 + Tcl_Interp *interp; /* Command interpreter in which variable is
1.1762 + * to be found. */
1.1763 + Tcl_Obj *part1Ptr; /* Points to an object holding the name of
1.1764 + * an array (if part2 is non-NULL) or the
1.1765 + * name of a variable. */
1.1766 + Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
1.1767 + * the name of an element in the array
1.1768 + * part1Ptr. */
1.1769 + long incrAmount; /* Amount to be added to variable. */
1.1770 + int flags; /* Various flags that tell how to incr value:
1.1771 + * any of TCL_GLOBAL_ONLY,
1.1772 + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
1.1773 + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
1.1774 +{
1.1775 + Var *varPtr, *arrayPtr;
1.1776 + char *part1, *part2;
1.1777 +
1.1778 + part1 = TclGetString(part1Ptr);
1.1779 + part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr));
1.1780 +
1.1781 + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
1.1782 + 0, 1, &arrayPtr);
1.1783 + if (varPtr == NULL) {
1.1784 + Tcl_AddObjErrorInfo(interp,
1.1785 + "\n (reading value of variable to increment)", -1);
1.1786 + return NULL;
1.1787 + }
1.1788 + return TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2,
1.1789 + incrAmount, flags);
1.1790 +}
1.1791 +
1.1792 +/*
1.1793 + *----------------------------------------------------------------------
1.1794 + *
1.1795 + * TclPtrIncrVar --
1.1796 + *
1.1797 + * Given the pointers to a variable and possible containing array,
1.1798 + * increment the Tcl object value of the variable by a specified
1.1799 + * amount.
1.1800 + *
1.1801 + * Results:
1.1802 + * Returns a pointer to the Tcl_Obj holding the new value of the
1.1803 + * variable. If the specified variable doesn't exist, or there is a
1.1804 + * clash in array usage, or an error occurs while executing variable
1.1805 + * traces, then NULL is returned and a message will be left in
1.1806 + * the interpreter's result.
1.1807 + *
1.1808 + * Side effects:
1.1809 + * The value of the given variable is incremented by the specified
1.1810 + * amount. If either the array or the entry didn't exist then a new
1.1811 + * variable is created. The ref count for the returned object is _not_
1.1812 + * incremented to reflect the returned reference; if you want to keep a
1.1813 + * reference to the object you must increment its ref count yourself.
1.1814 + *
1.1815 + *----------------------------------------------------------------------
1.1816 + */
1.1817 +
1.1818 +Tcl_Obj *
1.1819 +TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags)
1.1820 + Tcl_Interp *interp; /* Command interpreter in which variable is
1.1821 + * to be found. */
1.1822 + Var *varPtr;
1.1823 + Var *arrayPtr;
1.1824 + CONST char *part1; /* Points to an object holding the name of
1.1825 + * an array (if part2 is non-NULL) or the
1.1826 + * name of a variable. */
1.1827 + CONST char *part2; /* If non-null, points to an object holding
1.1828 + * the name of an element in the array
1.1829 + * part1Ptr. */
1.1830 + CONST long incrAmount; /* Amount to be added to variable. */
1.1831 + CONST int flags; /* Various flags that tell how to incr value:
1.1832 + * any of TCL_GLOBAL_ONLY,
1.1833 + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
1.1834 + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
1.1835 +{
1.1836 + register Tcl_Obj *varValuePtr;
1.1837 + int createdNewObj; /* Set 1 if var's value object is shared
1.1838 + * so we must increment a copy (i.e. copy
1.1839 + * on write). */
1.1840 + long i;
1.1841 +
1.1842 + varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
1.1843 +
1.1844 + if (varValuePtr == NULL) {
1.1845 + Tcl_AddObjErrorInfo(interp,
1.1846 + "\n (reading value of variable to increment)", -1);
1.1847 + return NULL;
1.1848 + }
1.1849 +
1.1850 + /*
1.1851 + * Increment the variable's value. If the object is unshared we can
1.1852 + * modify it directly, otherwise we must create a new copy to modify:
1.1853 + * this is "copy on write". Then free the variable's old string
1.1854 + * representation, if any, since it will no longer be valid.
1.1855 + */
1.1856 +
1.1857 + createdNewObj = 0;
1.1858 + if (Tcl_IsShared(varValuePtr)) {
1.1859 + varValuePtr = Tcl_DuplicateObj(varValuePtr);
1.1860 + createdNewObj = 1;
1.1861 + }
1.1862 + if (varValuePtr->typePtr == &tclWideIntType) {
1.1863 + Tcl_WideInt wide;
1.1864 + TclGetWide(wide,varValuePtr);
1.1865 + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
1.1866 + } else if (varValuePtr->typePtr == &tclIntType) {
1.1867 + i = varValuePtr->internalRep.longValue;
1.1868 + Tcl_SetIntObj(varValuePtr, i + incrAmount);
1.1869 + } else {
1.1870 + /*
1.1871 + * Not an integer or wide internal-rep...
1.1872 + */
1.1873 + Tcl_WideInt wide;
1.1874 + if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) {
1.1875 + if (createdNewObj) {
1.1876 + Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */
1.1877 + }
1.1878 + return NULL;
1.1879 + }
1.1880 + if (wide <= Tcl_LongAsWide(LONG_MAX)
1.1881 + && wide >= Tcl_LongAsWide(LONG_MIN)) {
1.1882 + Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount);
1.1883 + } else {
1.1884 + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
1.1885 + }
1.1886 + }
1.1887 +
1.1888 + /*
1.1889 + * Store the variable's new value and run any write traces.
1.1890 + */
1.1891 +
1.1892 + return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
1.1893 + varValuePtr, flags);
1.1894 +}
1.1895 +
1.1896 +/*
1.1897 + *----------------------------------------------------------------------
1.1898 + *
1.1899 + * Tcl_UnsetVar --
1.1900 + *
1.1901 + * Delete a variable, so that it may not be accessed anymore.
1.1902 + *
1.1903 + * Results:
1.1904 + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
1.1905 + * if the variable can't be unset. In the event of an error,
1.1906 + * if the TCL_LEAVE_ERR_MSG flag is set then an error message
1.1907 + * is left in the interp's result.
1.1908 + *
1.1909 + * Side effects:
1.1910 + * If varName is defined as a local or global variable in interp,
1.1911 + * it is deleted.
1.1912 + *
1.1913 + *----------------------------------------------------------------------
1.1914 + */
1.1915 +
1.1916 +EXPORT_C int
1.1917 +Tcl_UnsetVar(interp, varName, flags)
1.1918 + Tcl_Interp *interp; /* Command interpreter in which varName is
1.1919 + * to be looked up. */
1.1920 + CONST char *varName; /* Name of a variable in interp. May be
1.1921 + * either a scalar name or an array name
1.1922 + * or an element in an array. */
1.1923 + int flags; /* OR-ed combination of any of
1.1924 + * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or
1.1925 + * TCL_LEAVE_ERR_MSG. */
1.1926 +{
1.1927 + return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
1.1928 +}
1.1929 +
1.1930 +/*
1.1931 + *----------------------------------------------------------------------
1.1932 + *
1.1933 + * Tcl_UnsetVar2 --
1.1934 + *
1.1935 + * Delete a variable, given a 2-part name.
1.1936 + *
1.1937 + * Results:
1.1938 + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
1.1939 + * if the variable can't be unset. In the event of an error,
1.1940 + * if the TCL_LEAVE_ERR_MSG flag is set then an error message
1.1941 + * is left in the interp's result.
1.1942 + *
1.1943 + * Side effects:
1.1944 + * If part1 and part2 indicate a local or global variable in interp,
1.1945 + * it is deleted. If part1 is an array name and part2 is NULL, then
1.1946 + * the whole array is deleted.
1.1947 + *
1.1948 + *----------------------------------------------------------------------
1.1949 + */
1.1950 +
1.1951 +EXPORT_C int
1.1952 +Tcl_UnsetVar2(interp, part1, part2, flags)
1.1953 + Tcl_Interp *interp; /* Command interpreter in which varName is
1.1954 + * to be looked up. */
1.1955 + CONST char *part1; /* Name of variable or array. */
1.1956 + CONST char *part2; /* Name of element within array or NULL. */
1.1957 + int flags; /* OR-ed combination of any of
1.1958 + * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
1.1959 + * TCL_LEAVE_ERR_MSG. */
1.1960 +{
1.1961 + int result;
1.1962 + Tcl_Obj *part1Ptr;
1.1963 +
1.1964 + part1Ptr = Tcl_NewStringObj(part1, -1);
1.1965 + Tcl_IncrRefCount(part1Ptr);
1.1966 + /* Filter to pass through only the flags this interface supports. */
1.1967 + flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
1.1968 + result = TclObjUnsetVar2(interp, part1Ptr, part2, flags);
1.1969 + TclDecrRefCount(part1Ptr);
1.1970 +
1.1971 + return result;
1.1972 +}
1.1973 +
1.1974 +
1.1975 +/*
1.1976 + *----------------------------------------------------------------------
1.1977 + *
1.1978 + * TclObjUnsetVar2 --
1.1979 + *
1.1980 + * Delete a variable, given a 2-object name.
1.1981 + *
1.1982 + * Results:
1.1983 + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
1.1984 + * if the variable can't be unset. In the event of an error,
1.1985 + * if the TCL_LEAVE_ERR_MSG flag is set then an error message
1.1986 + * is left in the interp's result.
1.1987 + *
1.1988 + * Side effects:
1.1989 + * If part1ptr and part2Ptr indicate a local or global variable in interp,
1.1990 + * it is deleted. If part1Ptr is an array name and part2Ptr is NULL, then
1.1991 + * the whole array is deleted.
1.1992 + *
1.1993 + *----------------------------------------------------------------------
1.1994 + */
1.1995 +
1.1996 +int
1.1997 +TclObjUnsetVar2(interp, part1Ptr, part2, flags)
1.1998 + Tcl_Interp *interp; /* Command interpreter in which varName is
1.1999 + * to be looked up. */
1.2000 + Tcl_Obj *part1Ptr; /* Name of variable or array. */
1.2001 + CONST char *part2; /* Name of element within array or NULL. */
1.2002 + int flags; /* OR-ed combination of any of
1.2003 + * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
1.2004 + * TCL_LEAVE_ERR_MSG. */
1.2005 +{
1.2006 + Var *varPtr;
1.2007 + Interp *iPtr = (Interp *) interp;
1.2008 + Var *arrayPtr;
1.2009 + int result;
1.2010 + char *part1;
1.2011 +
1.2012 + part1 = TclGetString(part1Ptr);
1.2013 + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "unset",
1.2014 + /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
1.2015 + if (varPtr == NULL) {
1.2016 + return TCL_ERROR;
1.2017 + }
1.2018 +
1.2019 + result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK);
1.2020 +
1.2021 + /*
1.2022 + * Keep the variable alive until we're done with it. We used to
1.2023 + * increase/decrease the refCount for each operation, making it
1.2024 + * hard to find [Bug 735335] - caused by unsetting the variable
1.2025 + * whose value was the variable's name.
1.2026 + */
1.2027 +
1.2028 + varPtr->refCount++;
1.2029 +
1.2030 + UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags);
1.2031 +
1.2032 + /*
1.2033 + * It's an error to unset an undefined variable.
1.2034 + */
1.2035 +
1.2036 + if (result != TCL_OK) {
1.2037 + if (flags & TCL_LEAVE_ERR_MSG) {
1.2038 + VarErrMsg(interp, part1, part2, "unset",
1.2039 + ((arrayPtr == NULL) ? noSuchVar : noSuchElement));
1.2040 + }
1.2041 + }
1.2042 +
1.2043 + /*
1.2044 + * Try to avoid keeping the Var struct allocated due to a tclNsVarNameType
1.2045 + * keeping a reference. This removes some additional exteriorisations of
1.2046 + * [Bug 736729], but may be a good thing independently of the bug.
1.2047 + */
1.2048 +
1.2049 + if (part1Ptr->typePtr == &tclNsVarNameType) {
1.2050 + part1Ptr->typePtr->freeIntRepProc(part1Ptr);
1.2051 + part1Ptr->typePtr = NULL;
1.2052 + }
1.2053 +
1.2054 + /*
1.2055 + * Finally, if the variable is truly not in use then free up its Var
1.2056 + * structure and remove it from its hash table, if any. The ref count of
1.2057 + * its value object, if any, was decremented above.
1.2058 + */
1.2059 +
1.2060 + varPtr->refCount--;
1.2061 + CleanupVar(varPtr, arrayPtr);
1.2062 + return result;
1.2063 +}
1.2064 +
1.2065 +/*
1.2066 + *----------------------------------------------------------------------
1.2067 + *
1.2068 + * UnsetVarStruct --
1.2069 + *
1.2070 + * Unset and delete a variable. This does the internal work for
1.2071 + * TclObjUnsetVar2 and TclDeleteNamespaceVars, which call here for each
1.2072 + * variable to be unset and deleted.
1.2073 + *
1.2074 + * Results:
1.2075 + * None.
1.2076 + *
1.2077 + * Side effects:
1.2078 + * If the arguments indicate a local or global variable in iPtr, it is
1.2079 + * unset and deleted.
1.2080 + *
1.2081 + *----------------------------------------------------------------------
1.2082 + */
1.2083 +
1.2084 +static void
1.2085 +UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags)
1.2086 + Var *varPtr;
1.2087 + Var *arrayPtr;
1.2088 + Interp *iPtr;
1.2089 + CONST char *part1;
1.2090 + CONST char *part2;
1.2091 + int flags;
1.2092 +{
1.2093 + Var dummyVar;
1.2094 + Var *dummyVarPtr;
1.2095 + ActiveVarTrace *activePtr;
1.2096 +
1.2097 + if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
1.2098 + DeleteSearches(arrayPtr);
1.2099 + }
1.2100 +
1.2101 + /*
1.2102 + * For global/upvar variables referenced in procedures, decrement
1.2103 + * the reference count on the variable referred to, and free
1.2104 + * the referenced variable if it's no longer needed.
1.2105 + */
1.2106 +
1.2107 + if (TclIsVarLink(varPtr)) {
1.2108 + Var *linkPtr = varPtr->value.linkPtr;
1.2109 + linkPtr->refCount--;
1.2110 + if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr)
1.2111 + && (linkPtr->tracePtr == NULL)
1.2112 + && (linkPtr->flags & VAR_IN_HASHTABLE)) {
1.2113 + if (linkPtr->hPtr != NULL) {
1.2114 + Tcl_DeleteHashEntry(linkPtr->hPtr);
1.2115 + }
1.2116 + ckfree((char *) linkPtr);
1.2117 + }
1.2118 + }
1.2119 +
1.2120 + /*
1.2121 + * The code below is tricky, because of the possibility that
1.2122 + * a trace procedure might try to access a variable being
1.2123 + * deleted. To handle this situation gracefully, do things
1.2124 + * in three steps:
1.2125 + * 1. Copy the contents of the variable to a dummy variable
1.2126 + * structure, and mark the original Var structure as undefined.
1.2127 + * 2. Invoke traces and clean up the variable, using the dummy copy.
1.2128 + * 3. If at the end of this the original variable is still
1.2129 + * undefined and has no outstanding references, then delete
1.2130 + * it (but it could have gotten recreated by a trace).
1.2131 + */
1.2132 +
1.2133 + dummyVar = *varPtr;
1.2134 + TclSetVarUndefined(varPtr);
1.2135 + TclSetVarScalar(varPtr);
1.2136 + varPtr->value.objPtr = NULL; /* dummyVar points to any value object */
1.2137 + varPtr->tracePtr = NULL;
1.2138 + varPtr->searchPtr = NULL;
1.2139 +
1.2140 + /*
1.2141 + * Call trace procedures for the variable being deleted. Then delete
1.2142 + * its traces. Be sure to abort any other traces for the variable
1.2143 + * that are still pending. Special tricks:
1.2144 + * 1. We need to increment varPtr's refCount around this: CallVarTraces
1.2145 + * will use dummyVar so it won't increment varPtr's refCount itself.
1.2146 + * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to
1.2147 + * call unset traces even if other traces are pending.
1.2148 + */
1.2149 +
1.2150 + if ((dummyVar.tracePtr != NULL)
1.2151 + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
1.2152 + dummyVar.flags &= ~VAR_TRACE_ACTIVE;
1.2153 + CallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2,
1.2154 + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
1.2155 + | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0);
1.2156 + while (dummyVar.tracePtr != NULL) {
1.2157 + VarTrace *tracePtr = dummyVar.tracePtr;
1.2158 + dummyVar.tracePtr = tracePtr->nextPtr;
1.2159 + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
1.2160 + }
1.2161 + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
1.2162 + activePtr = activePtr->nextPtr) {
1.2163 + if (activePtr->varPtr == varPtr) {
1.2164 + activePtr->nextTracePtr = NULL;
1.2165 + }
1.2166 + }
1.2167 + }
1.2168 +
1.2169 + /*
1.2170 + * If the variable is an array, delete all of its elements. This must be
1.2171 + * done after calling the traces on the array, above (that's the way
1.2172 + * traces are defined). If it is a scalar, "discard" its object
1.2173 + * (decrement the ref count of its object, if any).
1.2174 + */
1.2175 +
1.2176 + dummyVarPtr = &dummyVar;
1.2177 + if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) {
1.2178 + DeleteArray(iPtr, part1, dummyVarPtr, (flags
1.2179 + & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS);
1.2180 + }
1.2181 + if (TclIsVarScalar(dummyVarPtr)
1.2182 + && (dummyVarPtr->value.objPtr != NULL)) {
1.2183 + Tcl_Obj *objPtr = dummyVarPtr->value.objPtr;
1.2184 + TclDecrRefCount(objPtr);
1.2185 + dummyVarPtr->value.objPtr = NULL;
1.2186 + }
1.2187 +
1.2188 + /*
1.2189 + * If the variable was a namespace variable, decrement its reference count.
1.2190 + */
1.2191 +
1.2192 + if (varPtr->flags & VAR_NAMESPACE_VAR) {
1.2193 + varPtr->flags &= ~VAR_NAMESPACE_VAR;
1.2194 + varPtr->refCount--;
1.2195 + }
1.2196 +
1.2197 +}
1.2198 +
1.2199 +/*
1.2200 + *----------------------------------------------------------------------
1.2201 + *
1.2202 + * Tcl_TraceVar --
1.2203 + *
1.2204 + * Arrange for reads and/or writes to a variable to cause a
1.2205 + * procedure to be invoked, which can monitor the operations
1.2206 + * and/or change their actions.
1.2207 + *
1.2208 + * Results:
1.2209 + * A standard Tcl return value.
1.2210 + *
1.2211 + * Side effects:
1.2212 + * A trace is set up on the variable given by varName, such that
1.2213 + * future references to the variable will be intermediated by
1.2214 + * proc. See the manual entry for complete details on the calling
1.2215 + * sequence for proc.
1.2216 + *
1.2217 + *----------------------------------------------------------------------
1.2218 + */
1.2219 +
1.2220 +EXPORT_C int
1.2221 +Tcl_TraceVar(interp, varName, flags, proc, clientData)
1.2222 + Tcl_Interp *interp; /* Interpreter in which variable is
1.2223 + * to be traced. */
1.2224 + CONST char *varName; /* Name of variable; may end with "(index)"
1.2225 + * to signify an array reference. */
1.2226 + int flags; /* OR-ed collection of bits, including any
1.2227 + * of TCL_TRACE_READS, TCL_TRACE_WRITES,
1.2228 + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
1.2229 + * TCL_NAMESPACE_ONLY. */
1.2230 + Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are
1.2231 + * invoked upon varName. */
1.2232 + ClientData clientData; /* Arbitrary argument to pass to proc. */
1.2233 +{
1.2234 + return Tcl_TraceVar2(interp, varName, (char *) NULL,
1.2235 + flags, proc, clientData);
1.2236 +}
1.2237 +
1.2238 +/*
1.2239 + *----------------------------------------------------------------------
1.2240 + *
1.2241 + * Tcl_TraceVar2 --
1.2242 + *
1.2243 + * Arrange for reads and/or writes to a variable to cause a
1.2244 + * procedure to be invoked, which can monitor the operations
1.2245 + * and/or change their actions.
1.2246 + *
1.2247 + * Results:
1.2248 + * A standard Tcl return value.
1.2249 + *
1.2250 + * Side effects:
1.2251 + * A trace is set up on the variable given by part1 and part2, such
1.2252 + * that future references to the variable will be intermediated by
1.2253 + * proc. See the manual entry for complete details on the calling
1.2254 + * sequence for proc.
1.2255 + *
1.2256 + *----------------------------------------------------------------------
1.2257 + */
1.2258 +
1.2259 +EXPORT_C int
1.2260 +Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
1.2261 + Tcl_Interp *interp; /* Interpreter in which variable is
1.2262 + * to be traced. */
1.2263 + CONST char *part1; /* Name of scalar variable or array. */
1.2264 + CONST char *part2; /* Name of element within array; NULL means
1.2265 + * trace applies to scalar variable or array
1.2266 + * as-a-whole. */
1.2267 + int flags; /* OR-ed collection of bits, including any
1.2268 + * of TCL_TRACE_READS, TCL_TRACE_WRITES,
1.2269 + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY,
1.2270 + * and TCL_NAMESPACE_ONLY. */
1.2271 + Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are
1.2272 + * invoked upon varName. */
1.2273 + ClientData clientData; /* Arbitrary argument to pass to proc. */
1.2274 +{
1.2275 + Var *varPtr, *arrayPtr;
1.2276 + register VarTrace *tracePtr;
1.2277 + int flagMask;
1.2278 +
1.2279 + /*
1.2280 + * We strip 'flags' down to just the parts which are relevant to
1.2281 + * TclLookupVar, to avoid conflicts between trace flags and
1.2282 + * internal namespace flags such as 'FIND_ONLY_NS'. This can
1.2283 + * now occur since we have trace flags with values 0x1000 and higher.
1.2284 + */
1.2285 + flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
1.2286 + varPtr = TclLookupVar(interp, part1, part2,
1.2287 + (flags & flagMask) | TCL_LEAVE_ERR_MSG,
1.2288 + "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
1.2289 + if (varPtr == NULL) {
1.2290 + return TCL_ERROR;
1.2291 + }
1.2292 +
1.2293 + /*
1.2294 + * Check for a nonsense flag combination. Note that this is a
1.2295 + * panic() because there should be no code path that ever sets
1.2296 + * both flags.
1.2297 + */
1.2298 + if ((flags&TCL_TRACE_RESULT_DYNAMIC) && (flags&TCL_TRACE_RESULT_OBJECT)) {
1.2299 + panic("bad result flag combination");
1.2300 + }
1.2301 +
1.2302 + /*
1.2303 + * Set up trace information.
1.2304 + */
1.2305 +
1.2306 + flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
1.2307 + TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
1.2308 +#ifndef TCL_REMOVE_OBSOLETE_TRACES
1.2309 + flagMask |= TCL_TRACE_OLD_STYLE;
1.2310 +#endif
1.2311 + tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
1.2312 + tracePtr->traceProc = proc;
1.2313 + tracePtr->clientData = clientData;
1.2314 + tracePtr->flags = flags & flagMask;
1.2315 + tracePtr->nextPtr = varPtr->tracePtr;
1.2316 + varPtr->tracePtr = tracePtr;
1.2317 + return TCL_OK;
1.2318 +}
1.2319 +
1.2320 +/*
1.2321 + *----------------------------------------------------------------------
1.2322 + *
1.2323 + * Tcl_UntraceVar --
1.2324 + *
1.2325 + * Remove a previously-created trace for a variable.
1.2326 + *
1.2327 + * Results:
1.2328 + * None.
1.2329 + *
1.2330 + * Side effects:
1.2331 + * If there exists a trace for the variable given by varName
1.2332 + * with the given flags, proc, and clientData, then that trace
1.2333 + * is removed.
1.2334 + *
1.2335 + *----------------------------------------------------------------------
1.2336 + */
1.2337 +
1.2338 +EXPORT_C void
1.2339 +Tcl_UntraceVar(interp, varName, flags, proc, clientData)
1.2340 + Tcl_Interp *interp; /* Interpreter containing variable. */
1.2341 + CONST char *varName; /* Name of variable; may end with "(index)"
1.2342 + * to signify an array reference. */
1.2343 + int flags; /* OR-ed collection of bits describing
1.2344 + * current trace, including any of
1.2345 + * TCL_TRACE_READS, TCL_TRACE_WRITES,
1.2346 + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY
1.2347 + * and TCL_NAMESPACE_ONLY. */
1.2348 + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
1.2349 + ClientData clientData; /* Arbitrary argument to pass to proc. */
1.2350 +{
1.2351 + Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData);
1.2352 +}
1.2353 +
1.2354 +/*
1.2355 + *----------------------------------------------------------------------
1.2356 + *
1.2357 + * Tcl_UntraceVar2 --
1.2358 + *
1.2359 + * Remove a previously-created trace for a variable.
1.2360 + *
1.2361 + * Results:
1.2362 + * None.
1.2363 + *
1.2364 + * Side effects:
1.2365 + * If there exists a trace for the variable given by part1
1.2366 + * and part2 with the given flags, proc, and clientData, then
1.2367 + * that trace is removed.
1.2368 + *
1.2369 + *----------------------------------------------------------------------
1.2370 + */
1.2371 +
1.2372 +EXPORT_C void
1.2373 +Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
1.2374 + Tcl_Interp *interp; /* Interpreter containing variable. */
1.2375 + CONST char *part1; /* Name of variable or array. */
1.2376 + CONST char *part2; /* Name of element within array; NULL means
1.2377 + * trace applies to scalar variable or array
1.2378 + * as-a-whole. */
1.2379 + int flags; /* OR-ed collection of bits describing
1.2380 + * current trace, including any of
1.2381 + * TCL_TRACE_READS, TCL_TRACE_WRITES,
1.2382 + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY,
1.2383 + * and TCL_NAMESPACE_ONLY. */
1.2384 + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
1.2385 + ClientData clientData; /* Arbitrary argument to pass to proc. */
1.2386 +{
1.2387 + register VarTrace *tracePtr;
1.2388 + VarTrace *prevPtr;
1.2389 + Var *varPtr, *arrayPtr;
1.2390 + Interp *iPtr = (Interp *) interp;
1.2391 + ActiveVarTrace *activePtr;
1.2392 + int flagMask;
1.2393 +
1.2394 + /*
1.2395 + * Set up a mask to mask out the parts of the flags that we are not
1.2396 + * interested in now.
1.2397 + */
1.2398 + flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
1.2399 + varPtr = TclLookupVar(interp, part1, part2, flags & flagMask,
1.2400 + /*msg*/ (char *) NULL,
1.2401 + /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
1.2402 + if (varPtr == NULL) {
1.2403 + return;
1.2404 + }
1.2405 +
1.2406 +
1.2407 + /*
1.2408 + * Set up a mask to mask out the parts of the flags that we are not
1.2409 + * interested in now.
1.2410 + */
1.2411 + flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
1.2412 + TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
1.2413 +#ifndef TCL_REMOVE_OBSOLETE_TRACES
1.2414 + flagMask |= TCL_TRACE_OLD_STYLE;
1.2415 +#endif
1.2416 + flags &= flagMask;
1.2417 + for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
1.2418 + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
1.2419 + if (tracePtr == NULL) {
1.2420 + return;
1.2421 + }
1.2422 + if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
1.2423 + && (tracePtr->clientData == clientData)) {
1.2424 + break;
1.2425 + }
1.2426 + }
1.2427 +
1.2428 + /*
1.2429 + * The code below makes it possible to delete traces while traces
1.2430 + * are active: it makes sure that the deleted trace won't be
1.2431 + * processed by CallVarTraces.
1.2432 + */
1.2433 +
1.2434 + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
1.2435 + activePtr = activePtr->nextPtr) {
1.2436 + if (activePtr->nextTracePtr == tracePtr) {
1.2437 + activePtr->nextTracePtr = tracePtr->nextPtr;
1.2438 + }
1.2439 + }
1.2440 + if (prevPtr == NULL) {
1.2441 + varPtr->tracePtr = tracePtr->nextPtr;
1.2442 + } else {
1.2443 + prevPtr->nextPtr = tracePtr->nextPtr;
1.2444 + }
1.2445 + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
1.2446 +
1.2447 + /*
1.2448 + * If this is the last trace on the variable, and the variable is
1.2449 + * unset and unused, then free up the variable.
1.2450 + */
1.2451 +
1.2452 + if (TclIsVarUndefined(varPtr)) {
1.2453 + CleanupVar(varPtr, (Var *) NULL);
1.2454 + }
1.2455 +}
1.2456 +
1.2457 +/*
1.2458 + *----------------------------------------------------------------------
1.2459 + *
1.2460 + * Tcl_VarTraceInfo --
1.2461 + *
1.2462 + * Return the clientData value associated with a trace on a
1.2463 + * variable. This procedure can also be used to step through
1.2464 + * all of the traces on a particular variable that have the
1.2465 + * same trace procedure.
1.2466 + *
1.2467 + * Results:
1.2468 + * The return value is the clientData value associated with
1.2469 + * a trace on the given variable. Information will only be
1.2470 + * returned for a trace with proc as trace procedure. If
1.2471 + * the clientData argument is NULL then the first such trace is
1.2472 + * returned; otherwise, the next relevant one after the one
1.2473 + * given by clientData will be returned. If the variable
1.2474 + * doesn't exist, or if there are no (more) traces for it,
1.2475 + * then NULL is returned.
1.2476 + *
1.2477 + * Side effects:
1.2478 + * None.
1.2479 + *
1.2480 + *----------------------------------------------------------------------
1.2481 + */
1.2482 +
1.2483 +EXPORT_C ClientData
1.2484 +Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
1.2485 + Tcl_Interp *interp; /* Interpreter containing variable. */
1.2486 + CONST char *varName; /* Name of variable; may end with "(index)"
1.2487 + * to signify an array reference. */
1.2488 + int flags; /* OR-ed combo or TCL_GLOBAL_ONLY,
1.2489 + * TCL_NAMESPACE_ONLY (can be 0). */
1.2490 + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
1.2491 + ClientData prevClientData; /* If non-NULL, gives last value returned
1.2492 + * by this procedure, so this call will
1.2493 + * return the next trace after that one.
1.2494 + * If NULL, this call will return the
1.2495 + * first trace. */
1.2496 +{
1.2497 + return Tcl_VarTraceInfo2(interp, varName, (char *) NULL,
1.2498 + flags, proc, prevClientData);
1.2499 +}
1.2500 +
1.2501 +/*
1.2502 + *----------------------------------------------------------------------
1.2503 + *
1.2504 + * Tcl_VarTraceInfo2 --
1.2505 + *
1.2506 + * Same as Tcl_VarTraceInfo, except takes name in two pieces
1.2507 + * instead of one.
1.2508 + *
1.2509 + * Results:
1.2510 + * Same as Tcl_VarTraceInfo.
1.2511 + *
1.2512 + * Side effects:
1.2513 + * None.
1.2514 + *
1.2515 + *----------------------------------------------------------------------
1.2516 + */
1.2517 +
1.2518 +EXPORT_C ClientData
1.2519 +Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
1.2520 + Tcl_Interp *interp; /* Interpreter containing variable. */
1.2521 + CONST char *part1; /* Name of variable or array. */
1.2522 + CONST char *part2; /* Name of element within array; NULL means
1.2523 + * trace applies to scalar variable or array
1.2524 + * as-a-whole. */
1.2525 + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
1.2526 + * TCL_NAMESPACE_ONLY. */
1.2527 + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
1.2528 + ClientData prevClientData; /* If non-NULL, gives last value returned
1.2529 + * by this procedure, so this call will
1.2530 + * return the next trace after that one.
1.2531 + * If NULL, this call will return the
1.2532 + * first trace. */
1.2533 +{
1.2534 + register VarTrace *tracePtr;
1.2535 + Var *varPtr, *arrayPtr;
1.2536 +
1.2537 + varPtr = TclLookupVar(interp, part1, part2,
1.2538 + flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY),
1.2539 + /*msg*/ (char *) NULL,
1.2540 + /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
1.2541 + if (varPtr == NULL) {
1.2542 + return NULL;
1.2543 + }
1.2544 +
1.2545 + /*
1.2546 + * Find the relevant trace, if any, and return its clientData.
1.2547 + */
1.2548 +
1.2549 + tracePtr = varPtr->tracePtr;
1.2550 + if (prevClientData != NULL) {
1.2551 + for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
1.2552 + if ((tracePtr->clientData == prevClientData)
1.2553 + && (tracePtr->traceProc == proc)) {
1.2554 + tracePtr = tracePtr->nextPtr;
1.2555 + break;
1.2556 + }
1.2557 + }
1.2558 + }
1.2559 + for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
1.2560 + if (tracePtr->traceProc == proc) {
1.2561 + return tracePtr->clientData;
1.2562 + }
1.2563 + }
1.2564 + return NULL;
1.2565 +}
1.2566 +
1.2567 +/*
1.2568 + *----------------------------------------------------------------------
1.2569 + *
1.2570 + * Tcl_UnsetObjCmd --
1.2571 + *
1.2572 + * This object-based procedure is invoked to process the "unset" Tcl
1.2573 + * command. See the user documentation for details on what it does.
1.2574 + *
1.2575 + * Results:
1.2576 + * A standard Tcl object result value.
1.2577 + *
1.2578 + * Side effects:
1.2579 + * See the user documentation.
1.2580 + *
1.2581 + *----------------------------------------------------------------------
1.2582 + */
1.2583 +
1.2584 + /* ARGSUSED */
1.2585 +int
1.2586 +Tcl_UnsetObjCmd(dummy, interp, objc, objv)
1.2587 + ClientData dummy; /* Not used. */
1.2588 + Tcl_Interp *interp; /* Current interpreter. */
1.2589 + int objc; /* Number of arguments. */
1.2590 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2591 +{
1.2592 + register int i, flags = TCL_LEAVE_ERR_MSG;
1.2593 + register char *name;
1.2594 +
1.2595 + if (objc < 1) {
1.2596 + Tcl_WrongNumArgs(interp, 1, objv,
1.2597 + "?-nocomplain? ?--? ?varName varName ...?");
1.2598 + return TCL_ERROR;
1.2599 + } else if (objc == 1) {
1.2600 + /*
1.2601 + * Do nothing if no arguments supplied, so as to match
1.2602 + * command documentation.
1.2603 + */
1.2604 + return TCL_OK;
1.2605 + }
1.2606 +
1.2607 + /*
1.2608 + * Simple, restrictive argument parsing. The only options are --
1.2609 + * and -nocomplain (which must come first and be given exactly to
1.2610 + * be an option).
1.2611 + */
1.2612 + i = 1;
1.2613 + name = TclGetString(objv[i]);
1.2614 + if (name[0] == '-') {
1.2615 + if (strcmp("-nocomplain", name) == 0) {
1.2616 + i++;
1.2617 + if (i == objc) {
1.2618 + return TCL_OK;
1.2619 + }
1.2620 + flags = 0;
1.2621 + name = TclGetString(objv[i]);
1.2622 + }
1.2623 + if (strcmp("--", name) == 0) {
1.2624 + i++;
1.2625 + }
1.2626 + }
1.2627 +
1.2628 + for (; i < objc; i++) {
1.2629 + if ((TclObjUnsetVar2(interp, objv[i], NULL, flags) != TCL_OK)
1.2630 + && (flags == TCL_LEAVE_ERR_MSG)) {
1.2631 + return TCL_ERROR;
1.2632 + }
1.2633 + }
1.2634 + return TCL_OK;
1.2635 +}
1.2636 +
1.2637 +/*
1.2638 + *----------------------------------------------------------------------
1.2639 + *
1.2640 + * Tcl_AppendObjCmd --
1.2641 + *
1.2642 + * This object-based procedure is invoked to process the "append"
1.2643 + * Tcl command. See the user documentation for details on what it does.
1.2644 + *
1.2645 + * Results:
1.2646 + * A standard Tcl object result value.
1.2647 + *
1.2648 + * Side effects:
1.2649 + * A variable's value may be changed.
1.2650 + *
1.2651 + *----------------------------------------------------------------------
1.2652 + */
1.2653 +
1.2654 + /* ARGSUSED */
1.2655 +int
1.2656 +Tcl_AppendObjCmd(dummy, interp, objc, objv)
1.2657 + ClientData dummy; /* Not used. */
1.2658 + Tcl_Interp *interp; /* Current interpreter. */
1.2659 + int objc; /* Number of arguments. */
1.2660 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2661 +{
1.2662 + Var *varPtr, *arrayPtr;
1.2663 + char *part1;
1.2664 +
1.2665 + register Tcl_Obj *varValuePtr = NULL;
1.2666 + /* Initialized to avoid compiler
1.2667 + * warning. */
1.2668 + int i;
1.2669 +
1.2670 + if (objc < 2) {
1.2671 + Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
1.2672 + return TCL_ERROR;
1.2673 + }
1.2674 +
1.2675 + if (objc == 2) {
1.2676 + varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
1.2677 + if (varValuePtr == NULL) {
1.2678 + return TCL_ERROR;
1.2679 + }
1.2680 + } else {
1.2681 + varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
1.2682 + "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
1.2683 + part1 = TclGetString(objv[1]);
1.2684 + if (varPtr == NULL) {
1.2685 + return TCL_ERROR;
1.2686 + }
1.2687 + for (i = 2; i < objc; i++) {
1.2688 + /*
1.2689 + * Note that we do not need to increase the refCount of
1.2690 + * the Var pointers: should a trace delete the variable,
1.2691 + * the return value of TclPtrSetVar will be NULL, and we
1.2692 + * will not access the variable again.
1.2693 + */
1.2694 +
1.2695 + varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL,
1.2696 + objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG));
1.2697 + if (varValuePtr == NULL) {
1.2698 + return TCL_ERROR;
1.2699 + }
1.2700 + }
1.2701 + }
1.2702 + Tcl_SetObjResult(interp, varValuePtr);
1.2703 + return TCL_OK;
1.2704 +}
1.2705 +
1.2706 +/*
1.2707 + *----------------------------------------------------------------------
1.2708 + *
1.2709 + * Tcl_LappendObjCmd --
1.2710 + *
1.2711 + * This object-based procedure is invoked to process the "lappend"
1.2712 + * Tcl command. See the user documentation for details on what it does.
1.2713 + *
1.2714 + * Results:
1.2715 + * A standard Tcl object result value.
1.2716 + *
1.2717 + * Side effects:
1.2718 + * A variable's value may be changed.
1.2719 + *
1.2720 + *----------------------------------------------------------------------
1.2721 + */
1.2722 +
1.2723 + /* ARGSUSED */
1.2724 +int
1.2725 +Tcl_LappendObjCmd(dummy, interp, objc, objv)
1.2726 + ClientData dummy; /* Not used. */
1.2727 + Tcl_Interp *interp; /* Current interpreter. */
1.2728 + int objc; /* Number of arguments. */
1.2729 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2730 +{
1.2731 + Tcl_Obj *varValuePtr, *newValuePtr;
1.2732 + register List *listRepPtr;
1.2733 + register Tcl_Obj **elemPtrs;
1.2734 + int numElems, numRequired, createdNewObj, i, j;
1.2735 + Var *varPtr, *arrayPtr;
1.2736 + char *part1;
1.2737 +
1.2738 + if (objc < 2) {
1.2739 + Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
1.2740 + return TCL_ERROR;
1.2741 + }
1.2742 + if (objc == 2) {
1.2743 + newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, 0);
1.2744 + if (newValuePtr == NULL) {
1.2745 + /*
1.2746 + * The variable doesn't exist yet. Just create it with an empty
1.2747 + * initial value.
1.2748 + */
1.2749 +
1.2750 + varValuePtr = Tcl_NewObj();
1.2751 + Tcl_IncrRefCount(varValuePtr);
1.2752 + newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr,
1.2753 + TCL_LEAVE_ERR_MSG);
1.2754 + Tcl_DecrRefCount(varValuePtr);
1.2755 + if (newValuePtr == NULL) {
1.2756 + return TCL_ERROR;
1.2757 + }
1.2758 + } else {
1.2759 + int result;
1.2760 +
1.2761 + result = Tcl_ListObjLength(interp, newValuePtr, &numElems);
1.2762 + if (result != TCL_OK) {
1.2763 + return result;
1.2764 + }
1.2765 + }
1.2766 + } else {
1.2767 + /*
1.2768 + * We have arguments to append. We used to call Tcl_SetVar2 to
1.2769 + * append each argument one at a time to ensure that traces were run
1.2770 + * for each append step. We now append the arguments all at once
1.2771 + * because it's faster. Note that a read trace and a write trace for
1.2772 + * the variable will now each only be called once. Also, if the
1.2773 + * variable's old value is unshared we modify it directly, otherwise
1.2774 + * we create a new copy to modify: this is "copy on write".
1.2775 + *
1.2776 + * Note that you have to protect the variable pointers around
1.2777 + * the TclPtrGetVar call to insure that they remain valid
1.2778 + * even if the variable was undefined and unused.
1.2779 + */
1.2780 +
1.2781 + varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
1.2782 + "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
1.2783 + if (varPtr == NULL) {
1.2784 + return TCL_ERROR;
1.2785 + }
1.2786 + varPtr->refCount++;
1.2787 + if (arrayPtr != NULL) {
1.2788 + arrayPtr->refCount++;
1.2789 + }
1.2790 + part1 = TclGetString(objv[1]);
1.2791 + varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL,
1.2792 + TCL_LEAVE_ERR_MSG);
1.2793 + varPtr->refCount--;
1.2794 + if (arrayPtr != NULL) {
1.2795 + arrayPtr->refCount--;
1.2796 + }
1.2797 +
1.2798 + createdNewObj = 0;
1.2799 + if (varValuePtr == NULL) {
1.2800 + /*
1.2801 + * We couldn't read the old value: either the var doesn't yet
1.2802 + * exist or it's an array element. If it's new, we will try to
1.2803 + * create it with Tcl_ObjSetVar2 below.
1.2804 + */
1.2805 +
1.2806 + varValuePtr = Tcl_NewObj();
1.2807 + createdNewObj = 1;
1.2808 + } else if (Tcl_IsShared(varValuePtr)) {
1.2809 + varValuePtr = Tcl_DuplicateObj(varValuePtr);
1.2810 + createdNewObj = 1;
1.2811 + }
1.2812 +
1.2813 + /*
1.2814 + * Convert the variable's old value to a list object if necessary.
1.2815 + */
1.2816 +
1.2817 + if (varValuePtr->typePtr != &tclListType) {
1.2818 + int result = tclListType.setFromAnyProc(interp, varValuePtr);
1.2819 + if (result != TCL_OK) {
1.2820 + if (createdNewObj) {
1.2821 + Tcl_DecrRefCount(varValuePtr); /* free unneeded obj. */
1.2822 + }
1.2823 + return result;
1.2824 + }
1.2825 + }
1.2826 + listRepPtr = (List *) varValuePtr->internalRep.twoPtrValue.ptr1;
1.2827 + elemPtrs = listRepPtr->elements;
1.2828 + numElems = listRepPtr->elemCount;
1.2829 +
1.2830 + /*
1.2831 + * If there is no room in the current array of element pointers,
1.2832 + * allocate a new, larger array and copy the pointers to it.
1.2833 + */
1.2834 +
1.2835 + numRequired = numElems + (objc-2);
1.2836 + if (numRequired > listRepPtr->maxElemCount) {
1.2837 + int newMax = (2 * numRequired);
1.2838 + Tcl_Obj **newElemPtrs = (Tcl_Obj **)
1.2839 + ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *)));
1.2840 +
1.2841 + memcpy((VOID *) newElemPtrs, (VOID *) elemPtrs,
1.2842 + (size_t) (numElems * sizeof(Tcl_Obj *)));
1.2843 + listRepPtr->maxElemCount = newMax;
1.2844 + listRepPtr->elements = newElemPtrs;
1.2845 + ckfree((char *) elemPtrs);
1.2846 + elemPtrs = newElemPtrs;
1.2847 + }
1.2848 +
1.2849 + /*
1.2850 + * Insert the new elements at the end of the list.
1.2851 + */
1.2852 +
1.2853 + for (i = 2, j = numElems; i < objc; i++, j++) {
1.2854 + elemPtrs[j] = objv[i];
1.2855 + Tcl_IncrRefCount(objv[i]);
1.2856 + }
1.2857 + listRepPtr->elemCount = numRequired;
1.2858 +
1.2859 + /*
1.2860 + * Invalidate and free any old string representation since it no
1.2861 + * longer reflects the list's internal representation.
1.2862 + */
1.2863 +
1.2864 + Tcl_InvalidateStringRep(varValuePtr);
1.2865 +
1.2866 + /*
1.2867 + * Now store the list object back into the variable. If there is an
1.2868 + * error setting the new value, decrement its ref count if it
1.2869 + * was new and we didn't create the variable.
1.2870 + */
1.2871 +
1.2872 + Tcl_IncrRefCount(varValuePtr);
1.2873 + newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL,
1.2874 + varValuePtr, TCL_LEAVE_ERR_MSG);
1.2875 + Tcl_DecrRefCount(varValuePtr);
1.2876 + if (newValuePtr == NULL) {
1.2877 + return TCL_ERROR;
1.2878 + }
1.2879 + }
1.2880 +
1.2881 + /*
1.2882 + * Set the interpreter's object result to refer to the variable's value
1.2883 + * object.
1.2884 + */
1.2885 +
1.2886 + Tcl_SetObjResult(interp, newValuePtr);
1.2887 + return TCL_OK;
1.2888 +}
1.2889 +
1.2890 +/*
1.2891 + *----------------------------------------------------------------------
1.2892 + *
1.2893 + * Tcl_ArrayObjCmd --
1.2894 + *
1.2895 + * This object-based procedure is invoked to process the "array" Tcl
1.2896 + * command. See the user documentation for details on what it does.
1.2897 + *
1.2898 + * Results:
1.2899 + * A standard Tcl result object.
1.2900 + *
1.2901 + * Side effects:
1.2902 + * See the user documentation.
1.2903 + *
1.2904 + *----------------------------------------------------------------------
1.2905 + */
1.2906 +
1.2907 + /* ARGSUSED */
1.2908 +int
1.2909 +Tcl_ArrayObjCmd(dummy, interp, objc, objv)
1.2910 + ClientData dummy; /* Not used. */
1.2911 + Tcl_Interp *interp; /* Current interpreter. */
1.2912 + int objc; /* Number of arguments. */
1.2913 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2914 +{
1.2915 + /*
1.2916 + * The list of constants below should match the arrayOptions string array
1.2917 + * below.
1.2918 + */
1.2919 +
1.2920 + enum {ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET,
1.2921 + ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE,
1.2922 + ARRAY_STARTSEARCH, ARRAY_STATISTICS, ARRAY_UNSET};
1.2923 + static CONST char *arrayOptions[] = {
1.2924 + "anymore", "donesearch", "exists", "get", "names", "nextelement",
1.2925 + "set", "size", "startsearch", "statistics", "unset", (char *) NULL
1.2926 + };
1.2927 +
1.2928 + Interp *iPtr = (Interp *) interp;
1.2929 + Var *varPtr, *arrayPtr;
1.2930 + Tcl_HashEntry *hPtr;
1.2931 + Tcl_Obj *resultPtr, *varNamePtr;
1.2932 + int notArray;
1.2933 + char *varName;
1.2934 + int index, result;
1.2935 +
1.2936 +
1.2937 + if (objc < 3) {
1.2938 + Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?");
1.2939 + return TCL_ERROR;
1.2940 + }
1.2941 +
1.2942 + if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option",
1.2943 + 0, &index) != TCL_OK) {
1.2944 + return TCL_ERROR;
1.2945 + }
1.2946 +
1.2947 + /*
1.2948 + * Locate the array variable
1.2949 + */
1.2950 +
1.2951 + varNamePtr = objv[2];
1.2952 + varName = TclGetString(varNamePtr);
1.2953 + varPtr = TclObjLookupVar(interp, varNamePtr, NULL, /*flags*/ 0,
1.2954 + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
1.2955 +
1.2956 + /*
1.2957 + * Special array trace used to keep the env array in sync for
1.2958 + * array names, array get, etc.
1.2959 + */
1.2960 +
1.2961 + if (varPtr != NULL && varPtr->tracePtr != NULL
1.2962 + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
1.2963 + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, varName, NULL,
1.2964 + (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
1.2965 + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1)) {
1.2966 + return TCL_ERROR;
1.2967 + }
1.2968 + }
1.2969 +
1.2970 + /*
1.2971 + * Verify that it is indeed an array variable. This test comes after
1.2972 + * the traces - the variable may actually become an array as an effect
1.2973 + * of said traces.
1.2974 + */
1.2975 +
1.2976 + notArray = 0;
1.2977 + if ((varPtr == NULL) || !TclIsVarArray(varPtr)
1.2978 + || TclIsVarUndefined(varPtr)) {
1.2979 + notArray = 1;
1.2980 + }
1.2981 +
1.2982 + /*
1.2983 + * We have to wait to get the resultPtr until here because
1.2984 + * CallVarTraces can affect the result.
1.2985 + */
1.2986 +
1.2987 + resultPtr = Tcl_GetObjResult(interp);
1.2988 +
1.2989 + switch (index) {
1.2990 + case ARRAY_ANYMORE: {
1.2991 + ArraySearch *searchPtr;
1.2992 +
1.2993 + if (objc != 4) {
1.2994 + Tcl_WrongNumArgs(interp, 2, objv,
1.2995 + "arrayName searchId");
1.2996 + return TCL_ERROR;
1.2997 + }
1.2998 + if (notArray) {
1.2999 + goto error;
1.3000 + }
1.3001 + searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
1.3002 + if (searchPtr == NULL) {
1.3003 + return TCL_ERROR;
1.3004 + }
1.3005 + while (1) {
1.3006 + Var *varPtr2;
1.3007 +
1.3008 + if (searchPtr->nextEntry != NULL) {
1.3009 + varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
1.3010 + if (!TclIsVarUndefined(varPtr2)) {
1.3011 + break;
1.3012 + }
1.3013 + }
1.3014 + searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
1.3015 + if (searchPtr->nextEntry == NULL) {
1.3016 + Tcl_SetIntObj(resultPtr, 0);
1.3017 + return TCL_OK;
1.3018 + }
1.3019 + }
1.3020 + Tcl_SetIntObj(resultPtr, 1);
1.3021 + break;
1.3022 + }
1.3023 + case ARRAY_DONESEARCH: {
1.3024 + ArraySearch *searchPtr, *prevPtr;
1.3025 +
1.3026 + if (objc != 4) {
1.3027 + Tcl_WrongNumArgs(interp, 2, objv,
1.3028 + "arrayName searchId");
1.3029 + return TCL_ERROR;
1.3030 + }
1.3031 + if (notArray) {
1.3032 + goto error;
1.3033 + }
1.3034 + searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
1.3035 + if (searchPtr == NULL) {
1.3036 + return TCL_ERROR;
1.3037 + }
1.3038 + if (varPtr->searchPtr == searchPtr) {
1.3039 + varPtr->searchPtr = searchPtr->nextPtr;
1.3040 + } else {
1.3041 + for (prevPtr = varPtr->searchPtr; ;
1.3042 + prevPtr = prevPtr->nextPtr) {
1.3043 + if (prevPtr->nextPtr == searchPtr) {
1.3044 + prevPtr->nextPtr = searchPtr->nextPtr;
1.3045 + break;
1.3046 + }
1.3047 + }
1.3048 + }
1.3049 + ckfree((char *) searchPtr);
1.3050 + break;
1.3051 + }
1.3052 + case ARRAY_EXISTS: {
1.3053 + if (objc != 3) {
1.3054 + Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
1.3055 + return TCL_ERROR;
1.3056 + }
1.3057 + Tcl_SetIntObj(resultPtr, !notArray);
1.3058 + break;
1.3059 + }
1.3060 + case ARRAY_GET: {
1.3061 + Tcl_HashSearch search;
1.3062 + Var *varPtr2;
1.3063 + char *pattern = NULL;
1.3064 + char *name;
1.3065 + Tcl_Obj *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr, **namePtrPtr;
1.3066 + int i, count;
1.3067 +
1.3068 + if ((objc != 3) && (objc != 4)) {
1.3069 + Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
1.3070 + return TCL_ERROR;
1.3071 + }
1.3072 + if (notArray) {
1.3073 + return TCL_OK;
1.3074 + }
1.3075 + if (objc == 4) {
1.3076 + pattern = TclGetString(objv[3]);
1.3077 + }
1.3078 +
1.3079 + /*
1.3080 + * Store the array names in a new object.
1.3081 + */
1.3082 +
1.3083 + nameLstPtr = Tcl_NewObj();
1.3084 + Tcl_IncrRefCount(nameLstPtr);
1.3085 +
1.3086 + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
1.3087 + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
1.3088 + varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
1.3089 + if (TclIsVarUndefined(varPtr2)) {
1.3090 + continue;
1.3091 + }
1.3092 + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
1.3093 + if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
1.3094 + continue; /* element name doesn't match pattern */
1.3095 + }
1.3096 +
1.3097 + namePtr = Tcl_NewStringObj(name, -1);
1.3098 + result = Tcl_ListObjAppendElement(interp, nameLstPtr,
1.3099 + namePtr);
1.3100 + if (result != TCL_OK) {
1.3101 + Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
1.3102 + Tcl_DecrRefCount(nameLstPtr);
1.3103 + return result;
1.3104 + }
1.3105 + }
1.3106 +
1.3107 + /*
1.3108 + * Make sure the Var structure of the array is not removed by
1.3109 + * a trace while we're working.
1.3110 + */
1.3111 +
1.3112 + varPtr->refCount++;
1.3113 +
1.3114 + /*
1.3115 + * Get the array values corresponding to each element name
1.3116 + */
1.3117 +
1.3118 + tmpResPtr = Tcl_NewObj();
1.3119 + result = Tcl_ListObjGetElements(interp, nameLstPtr,
1.3120 + &count, &namePtrPtr);
1.3121 + if (result != TCL_OK) {
1.3122 + goto errorInArrayGet;
1.3123 + }
1.3124 +
1.3125 + for (i = 0; i < count; i++) {
1.3126 + namePtr = *namePtrPtr++;
1.3127 + valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr,
1.3128 + TCL_LEAVE_ERR_MSG);
1.3129 + if (valuePtr == NULL) {
1.3130 + /*
1.3131 + * Some trace played a trick on us; we need to diagnose to
1.3132 + * adapt our behaviour: was the array element unset, or did
1.3133 + * the modification modify the complete array?
1.3134 + */
1.3135 +
1.3136 + if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
1.3137 + /*
1.3138 + * The array itself looks OK, the variable was
1.3139 + * undefined: forget it.
1.3140 + */
1.3141 +
1.3142 + continue;
1.3143 + } else {
1.3144 + result = TCL_ERROR;
1.3145 + goto errorInArrayGet;
1.3146 + }
1.3147 + }
1.3148 + result = Tcl_ListObjAppendElement(interp, tmpResPtr, namePtr);
1.3149 + if (result != TCL_OK) {
1.3150 + goto errorInArrayGet;
1.3151 + }
1.3152 + result = Tcl_ListObjAppendElement(interp, tmpResPtr, valuePtr);
1.3153 + if (result != TCL_OK) {
1.3154 + goto errorInArrayGet;
1.3155 + }
1.3156 + }
1.3157 + varPtr->refCount--;
1.3158 + Tcl_SetObjResult(interp, tmpResPtr);
1.3159 + Tcl_DecrRefCount(nameLstPtr);
1.3160 + break;
1.3161 +
1.3162 + errorInArrayGet:
1.3163 + varPtr->refCount--;
1.3164 + Tcl_DecrRefCount(nameLstPtr);
1.3165 + Tcl_DecrRefCount(tmpResPtr); /* free unneeded temp result obj */
1.3166 + return result;
1.3167 + }
1.3168 + case ARRAY_NAMES: {
1.3169 + Tcl_HashSearch search;
1.3170 + Var *varPtr2;
1.3171 + char *pattern = NULL;
1.3172 + char *name;
1.3173 + Tcl_Obj *namePtr;
1.3174 + int mode, matched = 0;
1.3175 + static CONST char *options[] = {
1.3176 + "-exact", "-glob", "-regexp", (char *) NULL
1.3177 + };
1.3178 + enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP };
1.3179 +
1.3180 + mode = OPT_GLOB;
1.3181 +
1.3182 + if ((objc < 3) || (objc > 5)) {
1.3183 + Tcl_WrongNumArgs(interp, 2, objv,
1.3184 + "arrayName ?mode? ?pattern?");
1.3185 + return TCL_ERROR;
1.3186 + }
1.3187 + if (notArray) {
1.3188 + return TCL_OK;
1.3189 + }
1.3190 + if (objc == 4) {
1.3191 + pattern = Tcl_GetString(objv[3]);
1.3192 + } else if (objc == 5) {
1.3193 + pattern = Tcl_GetString(objv[4]);
1.3194 + if (Tcl_GetIndexFromObj(interp, objv[3], options, "option",
1.3195 + 0, &mode) != TCL_OK) {
1.3196 + return TCL_ERROR;
1.3197 + }
1.3198 + }
1.3199 + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
1.3200 + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
1.3201 + varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
1.3202 + if (TclIsVarUndefined(varPtr2)) {
1.3203 + continue;
1.3204 + }
1.3205 + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
1.3206 + if (objc > 3) {
1.3207 + switch ((enum options) mode) {
1.3208 + case OPT_EXACT:
1.3209 + matched = (strcmp(name, pattern) == 0);
1.3210 + break;
1.3211 + case OPT_GLOB:
1.3212 + matched = Tcl_StringMatch(name, pattern);
1.3213 + break;
1.3214 + case OPT_REGEXP:
1.3215 + matched = Tcl_RegExpMatch(interp, name,
1.3216 + pattern);
1.3217 + if (matched < 0) {
1.3218 + return TCL_ERROR;
1.3219 + }
1.3220 + break;
1.3221 + }
1.3222 + if (matched == 0) {
1.3223 + continue;
1.3224 + }
1.3225 + }
1.3226 +
1.3227 + namePtr = Tcl_NewStringObj(name, -1);
1.3228 + result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
1.3229 + if (result != TCL_OK) {
1.3230 + Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
1.3231 + return result;
1.3232 + }
1.3233 + }
1.3234 + break;
1.3235 + }
1.3236 + case ARRAY_NEXTELEMENT: {
1.3237 + ArraySearch *searchPtr;
1.3238 + Tcl_HashEntry *hPtr;
1.3239 +
1.3240 + if (objc != 4) {
1.3241 + Tcl_WrongNumArgs(interp, 2, objv,
1.3242 + "arrayName searchId");
1.3243 + return TCL_ERROR;
1.3244 + }
1.3245 + if (notArray) {
1.3246 + goto error;
1.3247 + }
1.3248 + searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
1.3249 + if (searchPtr == NULL) {
1.3250 + return TCL_ERROR;
1.3251 + }
1.3252 + while (1) {
1.3253 + Var *varPtr2;
1.3254 +
1.3255 + hPtr = searchPtr->nextEntry;
1.3256 + if (hPtr == NULL) {
1.3257 + hPtr = Tcl_NextHashEntry(&searchPtr->search);
1.3258 + if (hPtr == NULL) {
1.3259 + return TCL_OK;
1.3260 + }
1.3261 + } else {
1.3262 + searchPtr->nextEntry = NULL;
1.3263 + }
1.3264 + varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
1.3265 + if (!TclIsVarUndefined(varPtr2)) {
1.3266 + break;
1.3267 + }
1.3268 + }
1.3269 + Tcl_SetStringObj(resultPtr,
1.3270 + Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1);
1.3271 + break;
1.3272 + }
1.3273 + case ARRAY_SET: {
1.3274 + if (objc != 4) {
1.3275 + Tcl_WrongNumArgs(interp, 2, objv, "arrayName list");
1.3276 + return TCL_ERROR;
1.3277 + }
1.3278 + return(TclArraySet(interp, objv[2], objv[3]));
1.3279 + }
1.3280 + case ARRAY_SIZE: {
1.3281 + Tcl_HashSearch search;
1.3282 + Var *varPtr2;
1.3283 + int size;
1.3284 +
1.3285 + if (objc != 3) {
1.3286 + Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
1.3287 + return TCL_ERROR;
1.3288 + }
1.3289 + size = 0;
1.3290 + if (!notArray) {
1.3291 + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr,
1.3292 + &search);
1.3293 + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
1.3294 + varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
1.3295 + if (TclIsVarUndefined(varPtr2)) {
1.3296 + continue;
1.3297 + }
1.3298 + size++;
1.3299 + }
1.3300 + }
1.3301 + Tcl_SetIntObj(resultPtr, size);
1.3302 + break;
1.3303 + }
1.3304 + case ARRAY_STARTSEARCH: {
1.3305 + ArraySearch *searchPtr;
1.3306 +
1.3307 + if (objc != 3) {
1.3308 + Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
1.3309 + return TCL_ERROR;
1.3310 + }
1.3311 + if (notArray) {
1.3312 + goto error;
1.3313 + }
1.3314 + searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
1.3315 + if (varPtr->searchPtr == NULL) {
1.3316 + searchPtr->id = 1;
1.3317 + Tcl_AppendStringsToObj(resultPtr, "s-1-", varName,
1.3318 + (char *) NULL);
1.3319 + } else {
1.3320 + char string[TCL_INTEGER_SPACE];
1.3321 +
1.3322 + searchPtr->id = varPtr->searchPtr->id + 1;
1.3323 + TclFormatInt(string, searchPtr->id);
1.3324 + Tcl_AppendStringsToObj(resultPtr, "s-", string, "-", varName,
1.3325 + (char *) NULL);
1.3326 + }
1.3327 + searchPtr->varPtr = varPtr;
1.3328 + searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
1.3329 + &searchPtr->search);
1.3330 + searchPtr->nextPtr = varPtr->searchPtr;
1.3331 + varPtr->searchPtr = searchPtr;
1.3332 + break;
1.3333 + }
1.3334 +
1.3335 + case ARRAY_STATISTICS: {
1.3336 + CONST char *stats;
1.3337 +
1.3338 + if (notArray) {
1.3339 + goto error;
1.3340 + }
1.3341 +
1.3342 + stats = Tcl_HashStats(varPtr->value.tablePtr);
1.3343 + if (stats != NULL) {
1.3344 + Tcl_SetStringObj(Tcl_GetObjResult(interp), stats, -1);
1.3345 + ckfree((void *)stats);
1.3346 + } else {
1.3347 + Tcl_SetResult(interp, "error reading array statistics",
1.3348 + TCL_STATIC);
1.3349 + return TCL_ERROR;
1.3350 + }
1.3351 + break;
1.3352 + }
1.3353 +
1.3354 + case ARRAY_UNSET: {
1.3355 + Tcl_HashSearch search;
1.3356 + Var *varPtr2;
1.3357 + char *pattern = NULL;
1.3358 + char *name;
1.3359 +
1.3360 + if ((objc != 3) && (objc != 4)) {
1.3361 + Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
1.3362 + return TCL_ERROR;
1.3363 + }
1.3364 + if (notArray) {
1.3365 + return TCL_OK;
1.3366 + }
1.3367 + if (objc == 3) {
1.3368 + /*
1.3369 + * When no pattern is given, just unset the whole array
1.3370 + */
1.3371 + if (TclObjUnsetVar2(interp, varNamePtr, NULL, 0)
1.3372 + != TCL_OK) {
1.3373 + return TCL_ERROR;
1.3374 + }
1.3375 + } else {
1.3376 + pattern = Tcl_GetString(objv[3]);
1.3377 + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr,
1.3378 + &search);
1.3379 + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
1.3380 + varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
1.3381 + if (TclIsVarUndefined(varPtr2)) {
1.3382 + continue;
1.3383 + }
1.3384 + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
1.3385 + if (Tcl_StringMatch(name, pattern) &&
1.3386 + (TclObjUnsetVar2(interp, varNamePtr, name, 0)
1.3387 + != TCL_OK)) {
1.3388 + return TCL_ERROR;
1.3389 + }
1.3390 + }
1.3391 + }
1.3392 + break;
1.3393 + }
1.3394 + }
1.3395 + return TCL_OK;
1.3396 +
1.3397 + error:
1.3398 + Tcl_AppendStringsToObj(resultPtr, "\"", varName, "\" isn't an array",
1.3399 + (char *) NULL);
1.3400 + return TCL_ERROR;
1.3401 +}
1.3402 +
1.3403 +/*
1.3404 + *----------------------------------------------------------------------
1.3405 + *
1.3406 + * TclArraySet --
1.3407 + *
1.3408 + * Set the elements of an array. If there are no elements to
1.3409 + * set, create an empty array. This routine is used by the
1.3410 + * Tcl_ArrayObjCmd and by the TclSetupEnv routine.
1.3411 + *
1.3412 + * Results:
1.3413 + * A standard Tcl result object.
1.3414 + *
1.3415 + * Side effects:
1.3416 + * A variable will be created if one does not already exist.
1.3417 + *
1.3418 + *----------------------------------------------------------------------
1.3419 + */
1.3420 +
1.3421 +int
1.3422 +TclArraySet(interp, arrayNameObj, arrayElemObj)
1.3423 + Tcl_Interp *interp; /* Current interpreter. */
1.3424 + Tcl_Obj *arrayNameObj; /* The array name. */
1.3425 + Tcl_Obj *arrayElemObj; /* The array elements list. If this is
1.3426 + * NULL, create an empty array. */
1.3427 +{
1.3428 + Var *varPtr, *arrayPtr;
1.3429 + Tcl_Obj **elemPtrs;
1.3430 + int result, elemLen, i, nameLen;
1.3431 + char *varName, *p;
1.3432 +
1.3433 + varName = Tcl_GetStringFromObj(arrayNameObj, &nameLen);
1.3434 + p = varName + nameLen - 1;
1.3435 + if (*p == ')') {
1.3436 + while (--p >= varName) {
1.3437 + if (*p == '(') {
1.3438 + VarErrMsg(interp, varName, NULL, "set", needArray);
1.3439 + return TCL_ERROR;
1.3440 + }
1.3441 + }
1.3442 + }
1.3443 +
1.3444 + varPtr = TclObjLookupVar(interp, arrayNameObj, NULL,
1.3445 + /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1,
1.3446 + /*createPart2*/ 0, &arrayPtr);
1.3447 + if (varPtr == NULL) {
1.3448 + return TCL_ERROR;
1.3449 + }
1.3450 +
1.3451 + if (arrayElemObj != NULL) {
1.3452 + result = Tcl_ListObjGetElements(interp, arrayElemObj,
1.3453 + &elemLen, &elemPtrs);
1.3454 + if (result != TCL_OK) {
1.3455 + return result;
1.3456 + }
1.3457 + if (elemLen & 1) {
1.3458 + Tcl_ResetResult(interp);
1.3459 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.3460 + "list must have an even number of elements", -1);
1.3461 + return TCL_ERROR;
1.3462 + }
1.3463 + if (elemLen > 0) {
1.3464 + /*
1.3465 + * We needn't worry about traces invalidating arrayPtr:
1.3466 + * should that be the case, TclPtrSetVar will return NULL
1.3467 + * so that we break out of the loop and return an error.
1.3468 + */
1.3469 +
1.3470 + for (i = 0; i < elemLen; i += 2) {
1.3471 + char *part2 = TclGetString(elemPtrs[i]);
1.3472 + Var *elemVarPtr = TclLookupArrayElement(interp, varName,
1.3473 + part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr);
1.3474 + if ((elemVarPtr == NULL) ||
1.3475 + (TclPtrSetVar(interp, elemVarPtr, varPtr, varName,
1.3476 + part2, elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL)) {
1.3477 + result = TCL_ERROR;
1.3478 + break;
1.3479 + }
1.3480 +
1.3481 + /*
1.3482 + * The TclPtrSetVar call might have shimmered
1.3483 + * arrayElemObj to another type, so re-fetch
1.3484 + * the pointers for safety.
1.3485 + */
1.3486 + Tcl_ListObjGetElements(NULL, arrayElemObj,
1.3487 + &elemLen, &elemPtrs);
1.3488 + }
1.3489 + return result;
1.3490 + }
1.3491 + }
1.3492 +
1.3493 + /*
1.3494 + * The list is empty make sure we have an array, or create
1.3495 + * one if necessary.
1.3496 + */
1.3497 +
1.3498 + if (varPtr != NULL) {
1.3499 + if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) {
1.3500 + /*
1.3501 + * Already an array, done.
1.3502 + */
1.3503 +
1.3504 + return TCL_OK;
1.3505 + }
1.3506 + if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
1.3507 + /*
1.3508 + * Either an array element, or a scalar: lose!
1.3509 + */
1.3510 +
1.3511 + VarErrMsg(interp, varName, (char *)NULL, "array set", needArray);
1.3512 + return TCL_ERROR;
1.3513 + }
1.3514 + }
1.3515 + TclSetVarArray(varPtr);
1.3516 + TclClearVarUndefined(varPtr);
1.3517 + varPtr->value.tablePtr =
1.3518 + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
1.3519 + Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
1.3520 + return TCL_OK;
1.3521 +}
1.3522 +
1.3523 +/*
1.3524 + *----------------------------------------------------------------------
1.3525 + *
1.3526 + * ObjMakeUpvar --
1.3527 + *
1.3528 + * This procedure does all of the work of the "global" and "upvar"
1.3529 + * commands.
1.3530 + *
1.3531 + * Results:
1.3532 + * A standard Tcl completion code. If an error occurs then an
1.3533 + * error message is left in iPtr->result.
1.3534 + *
1.3535 + * Side effects:
1.3536 + * The variable given by myName is linked to the variable in framePtr
1.3537 + * given by otherP1 and otherP2, so that references to myName are
1.3538 + * redirected to the other variable like a symbolic link.
1.3539 + *
1.3540 + *----------------------------------------------------------------------
1.3541 + */
1.3542 +
1.3543 +static int
1.3544 +ObjMakeUpvar(interp, framePtr, otherP1Ptr, otherP2, otherFlags, myName, myFlags, index)
1.3545 + Tcl_Interp *interp; /* Interpreter containing variables. Used
1.3546 + * for error messages, too. */
1.3547 + CallFrame *framePtr; /* Call frame containing "other" variable.
1.3548 + * NULL means use global :: context. */
1.3549 + Tcl_Obj *otherP1Ptr;
1.3550 + CONST char *otherP2; /* Two-part name of variable in framePtr. */
1.3551 + CONST int otherFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
1.3552 + * indicates scope of "other" variable. */
1.3553 + CONST char *myName; /* Name of variable which will refer to
1.3554 + * otherP1/otherP2. Must be a scalar. */
1.3555 + int myFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
1.3556 + * indicates scope of myName. */
1.3557 + int index; /* If the variable to be linked is an indexed
1.3558 + * scalar, this is its index. Otherwise, -1. */
1.3559 +{
1.3560 + Interp *iPtr = (Interp *) interp;
1.3561 + Var *otherPtr, *varPtr, *arrayPtr;
1.3562 + CallFrame *varFramePtr;
1.3563 + CONST char *errMsg;
1.3564 +
1.3565 + /*
1.3566 + * Find "other" in "framePtr". If not looking up other in just the
1.3567 + * current namespace, temporarily replace the current var frame
1.3568 + * pointer in the interpreter in order to use TclObjLookupVar.
1.3569 + */
1.3570 +
1.3571 + varFramePtr = iPtr->varFramePtr;
1.3572 + if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
1.3573 + iPtr->varFramePtr = framePtr;
1.3574 + }
1.3575 + otherPtr = TclObjLookupVar(interp, otherP1Ptr, otherP2,
1.3576 + (otherFlags | TCL_LEAVE_ERR_MSG), "access",
1.3577 + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
1.3578 + if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
1.3579 + iPtr->varFramePtr = varFramePtr;
1.3580 + }
1.3581 + if (otherPtr == NULL) {
1.3582 + return TCL_ERROR;
1.3583 + }
1.3584 +
1.3585 + if (index >= 0) {
1.3586 + if (!varFramePtr->isProcCallFrame) {
1.3587 + panic("ObjMakeUpvar called with an index outside from a proc.\n");
1.3588 + }
1.3589 + varPtr = &(varFramePtr->compiledLocals[index]);
1.3590 + } else {
1.3591 + /*
1.3592 + * Check that we are not trying to create a namespace var linked to
1.3593 + * a local variable in a procedure. If we allowed this, the local
1.3594 + * variable in the shorter-lived procedure frame could go away
1.3595 + * leaving the namespace var's reference invalid.
1.3596 + */
1.3597 +
1.3598 + if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL)
1.3599 + && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
1.3600 + || (varFramePtr == NULL)
1.3601 + || !varFramePtr->isProcCallFrame
1.3602 + || (strstr(myName, "::") != NULL))) {
1.3603 + Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
1.3604 + myName, "\": upvar won't create namespace variable that ",
1.3605 + "refers to procedure variable", (char *) NULL);
1.3606 + return TCL_ERROR;
1.3607 + }
1.3608 +
1.3609 + /*
1.3610 + * Lookup and eventually create the new variable. Set the flag bit
1.3611 + * LOOKUP_FOR_UPVAR to indicate the special resolution rules for
1.3612 + * upvar purposes:
1.3613 + * - Bug #696893 - variable is either proc-local or in the current
1.3614 + * namespace; never follow the second (global) resolution path
1.3615 + * - Bug #631741 - do not use special namespace or interp resolvers
1.3616 + */
1.3617 +
1.3618 + varPtr = TclLookupSimpleVar(interp, myName, (myFlags | LOOKUP_FOR_UPVAR),
1.3619 + /* create */ 1, &errMsg, &index);
1.3620 + if (varPtr == NULL) {
1.3621 + VarErrMsg(interp, myName, NULL, "create", errMsg);
1.3622 + return TCL_ERROR;
1.3623 + }
1.3624 + }
1.3625 +
1.3626 + if (varPtr == otherPtr) {
1.3627 + Tcl_SetResult((Tcl_Interp *) iPtr,
1.3628 + "can't upvar from variable to itself", TCL_STATIC);
1.3629 + return TCL_ERROR;
1.3630 + }
1.3631 +
1.3632 + if (varPtr->tracePtr != NULL) {
1.3633 + Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
1.3634 + "\" has traces: can't use for upvar", (char *) NULL);
1.3635 + return TCL_ERROR;
1.3636 + } else if (!TclIsVarUndefined(varPtr)) {
1.3637 + /*
1.3638 + * The variable already existed. Make sure this variable "varPtr"
1.3639 + * isn't the same as "otherPtr" (avoid circular links). Also, if
1.3640 + * it's not an upvar then it's an error. If it is an upvar, then
1.3641 + * just disconnect it from the thing it currently refers to.
1.3642 + */
1.3643 +
1.3644 + if (TclIsVarLink(varPtr)) {
1.3645 + Var *linkPtr = varPtr->value.linkPtr;
1.3646 + if (linkPtr == otherPtr) {
1.3647 + return TCL_OK;
1.3648 + }
1.3649 + linkPtr->refCount--;
1.3650 + if (TclIsVarUndefined(linkPtr)) {
1.3651 + CleanupVar(linkPtr, (Var *) NULL);
1.3652 + }
1.3653 + } else {
1.3654 + Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
1.3655 + "\" already exists", (char *) NULL);
1.3656 + return TCL_ERROR;
1.3657 + }
1.3658 + }
1.3659 + TclSetVarLink(varPtr);
1.3660 + TclClearVarUndefined(varPtr);
1.3661 + varPtr->value.linkPtr = otherPtr;
1.3662 + otherPtr->refCount++;
1.3663 + return TCL_OK;
1.3664 +}
1.3665 +
1.3666 +/*
1.3667 + *----------------------------------------------------------------------
1.3668 + *
1.3669 + * Tcl_UpVar --
1.3670 + *
1.3671 + * This procedure links one variable to another, just like
1.3672 + * the "upvar" command.
1.3673 + *
1.3674 + * Results:
1.3675 + * A standard Tcl completion code. If an error occurs then
1.3676 + * an error message is left in the interp's result.
1.3677 + *
1.3678 + * Side effects:
1.3679 + * The variable in frameName whose name is given by varName becomes
1.3680 + * accessible under the name localName, so that references to
1.3681 + * localName are redirected to the other variable like a symbolic
1.3682 + * link.
1.3683 + *
1.3684 + *----------------------------------------------------------------------
1.3685 + */
1.3686 +
1.3687 +EXPORT_C int
1.3688 +Tcl_UpVar(interp, frameName, varName, localName, flags)
1.3689 + Tcl_Interp *interp; /* Command interpreter in which varName is
1.3690 + * to be looked up. */
1.3691 + CONST char *frameName; /* Name of the frame containing the source
1.3692 + * variable, such as "1" or "#0". */
1.3693 + CONST char *varName; /* Name of a variable in interp to link to.
1.3694 + * May be either a scalar name or an
1.3695 + * element in an array. */
1.3696 + CONST char *localName; /* Name of link variable. */
1.3697 + int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
1.3698 + * indicates scope of localName. */
1.3699 +{
1.3700 + return Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags);
1.3701 +}
1.3702 +
1.3703 +/*
1.3704 + *----------------------------------------------------------------------
1.3705 + *
1.3706 + * Tcl_UpVar2 --
1.3707 + *
1.3708 + * This procedure links one variable to another, just like
1.3709 + * the "upvar" command.
1.3710 + *
1.3711 + * Results:
1.3712 + * A standard Tcl completion code. If an error occurs then
1.3713 + * an error message is left in the interp's result.
1.3714 + *
1.3715 + * Side effects:
1.3716 + * The variable in frameName whose name is given by part1 and
1.3717 + * part2 becomes accessible under the name localName, so that
1.3718 + * references to localName are redirected to the other variable
1.3719 + * like a symbolic link.
1.3720 + *
1.3721 + *----------------------------------------------------------------------
1.3722 + */
1.3723 +
1.3724 +EXPORT_C int
1.3725 +Tcl_UpVar2(interp, frameName, part1, part2, localName, flags)
1.3726 + Tcl_Interp *interp; /* Interpreter containing variables. Used
1.3727 + * for error messages too. */
1.3728 + CONST char *frameName; /* Name of the frame containing the source
1.3729 + * variable, such as "1" or "#0". */
1.3730 + CONST char *part1;
1.3731 + CONST char *part2; /* Two parts of source variable name to
1.3732 + * link to. */
1.3733 + CONST char *localName; /* Name of link variable. */
1.3734 + int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
1.3735 + * indicates scope of localName. */
1.3736 +{
1.3737 + int result;
1.3738 + CallFrame *framePtr;
1.3739 + Tcl_Obj *part1Ptr;
1.3740 +
1.3741 + if (TclGetFrame(interp, frameName, &framePtr) == -1) {
1.3742 + return TCL_ERROR;
1.3743 + }
1.3744 +
1.3745 + part1Ptr = Tcl_NewStringObj(part1, -1);
1.3746 + Tcl_IncrRefCount(part1Ptr);
1.3747 + result = ObjMakeUpvar(interp, framePtr, part1Ptr, part2, 0,
1.3748 + localName, flags, -1);
1.3749 + TclDecrRefCount(part1Ptr);
1.3750 +
1.3751 + return result;
1.3752 +}
1.3753 +
1.3754 +/*
1.3755 + *----------------------------------------------------------------------
1.3756 + *
1.3757 + * Tcl_GetVariableFullName --
1.3758 + *
1.3759 + * Given a Tcl_Var token returned by Tcl_FindNamespaceVar, this
1.3760 + * procedure appends to an object the namespace variable's full
1.3761 + * name, qualified by a sequence of parent namespace names.
1.3762 + *
1.3763 + * Results:
1.3764 + * None.
1.3765 + *
1.3766 + * Side effects:
1.3767 + * The variable's fully-qualified name is appended to the string
1.3768 + * representation of objPtr.
1.3769 + *
1.3770 + *----------------------------------------------------------------------
1.3771 + */
1.3772 +
1.3773 +void
1.3774 +Tcl_GetVariableFullName(interp, variable, objPtr)
1.3775 + Tcl_Interp *interp; /* Interpreter containing the variable. */
1.3776 + Tcl_Var variable; /* Token for the variable returned by a
1.3777 + * previous call to Tcl_FindNamespaceVar. */
1.3778 + Tcl_Obj *objPtr; /* Points to the object onto which the
1.3779 + * variable's full name is appended. */
1.3780 +{
1.3781 + Interp *iPtr = (Interp *) interp;
1.3782 + register Var *varPtr = (Var *) variable;
1.3783 + char *name;
1.3784 +
1.3785 + /*
1.3786 + * Add the full name of the containing namespace (if any), followed by
1.3787 + * the "::" separator, then the variable name.
1.3788 + */
1.3789 +
1.3790 + if (varPtr != NULL) {
1.3791 + if (!TclIsVarArrayElement(varPtr)) {
1.3792 + if (varPtr->nsPtr != NULL) {
1.3793 + Tcl_AppendToObj(objPtr, varPtr->nsPtr->fullName, -1);
1.3794 + if (varPtr->nsPtr != iPtr->globalNsPtr) {
1.3795 + Tcl_AppendToObj(objPtr, "::", 2);
1.3796 + }
1.3797 + }
1.3798 + if (varPtr->name != NULL) {
1.3799 + Tcl_AppendToObj(objPtr, varPtr->name, -1);
1.3800 + } else if (varPtr->hPtr != NULL) {
1.3801 + name = Tcl_GetHashKey(varPtr->hPtr->tablePtr, varPtr->hPtr);
1.3802 + Tcl_AppendToObj(objPtr, name, -1);
1.3803 + }
1.3804 + }
1.3805 + }
1.3806 +}
1.3807 +
1.3808 +/*
1.3809 + *----------------------------------------------------------------------
1.3810 + *
1.3811 + * Tcl_GlobalObjCmd --
1.3812 + *
1.3813 + * This object-based procedure is invoked to process the "global" Tcl
1.3814 + * command. See the user documentation for details on what it does.
1.3815 + *
1.3816 + * Results:
1.3817 + * A standard Tcl object result value.
1.3818 + *
1.3819 + * Side effects:
1.3820 + * See the user documentation.
1.3821 + *
1.3822 + *----------------------------------------------------------------------
1.3823 + */
1.3824 +
1.3825 +int
1.3826 +Tcl_GlobalObjCmd(dummy, interp, objc, objv)
1.3827 + ClientData dummy; /* Not used. */
1.3828 + Tcl_Interp *interp; /* Current interpreter. */
1.3829 + int objc; /* Number of arguments. */
1.3830 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.3831 +{
1.3832 + Interp *iPtr = (Interp *) interp;
1.3833 + register Tcl_Obj *objPtr;
1.3834 + char *varName;
1.3835 + register char *tail;
1.3836 + int result, i;
1.3837 +
1.3838 + if (objc < 2) {
1.3839 + Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?");
1.3840 + return TCL_ERROR;
1.3841 + }
1.3842 +
1.3843 + /*
1.3844 + * If we are not executing inside a Tcl procedure, just return.
1.3845 + */
1.3846 +
1.3847 + if ((iPtr->varFramePtr == NULL)
1.3848 + || !iPtr->varFramePtr->isProcCallFrame) {
1.3849 + return TCL_OK;
1.3850 + }
1.3851 +
1.3852 + for (i = 1; i < objc; i++) {
1.3853 + /*
1.3854 + * Make a local variable linked to its counterpart in the global ::
1.3855 + * namespace.
1.3856 + */
1.3857 +
1.3858 + objPtr = objv[i];
1.3859 + varName = TclGetString(objPtr);
1.3860 +
1.3861 + /*
1.3862 + * The variable name might have a scope qualifier, but the name for
1.3863 + * the local "link" variable must be the simple name at the tail.
1.3864 + */
1.3865 +
1.3866 + for (tail = varName; *tail != '\0'; tail++) {
1.3867 + /* empty body */
1.3868 + }
1.3869 + while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
1.3870 + tail--;
1.3871 + }
1.3872 + if ((*tail == ':') && (tail > varName)) {
1.3873 + tail++;
1.3874 + }
1.3875 +
1.3876 + /*
1.3877 + * Link to the variable "varName" in the global :: namespace.
1.3878 + */
1.3879 +
1.3880 + result = ObjMakeUpvar(interp, (CallFrame *) NULL,
1.3881 + objPtr, NULL, /*otherFlags*/ TCL_GLOBAL_ONLY,
1.3882 + /*myName*/ tail, /*myFlags*/ 0, -1);
1.3883 + if (result != TCL_OK) {
1.3884 + return result;
1.3885 + }
1.3886 + }
1.3887 + return TCL_OK;
1.3888 +}
1.3889 +
1.3890 +/*
1.3891 + *----------------------------------------------------------------------
1.3892 + *
1.3893 + * Tcl_VariableObjCmd --
1.3894 + *
1.3895 + * Invoked to implement the "variable" command that creates one or more
1.3896 + * global variables. Handles the following syntax:
1.3897 + *
1.3898 + * variable ?name value...? name ?value?
1.3899 + *
1.3900 + * One or more variables can be created. The variables are initialized
1.3901 + * with the specified values. The value for the last variable is
1.3902 + * optional.
1.3903 + *
1.3904 + * If the variable does not exist, it is created and given the optional
1.3905 + * value. If it already exists, it is simply set to the optional
1.3906 + * value. Normally, "name" is an unqualified name, so it is created in
1.3907 + * the current namespace. If it includes namespace qualifiers, it can
1.3908 + * be created in another namespace.
1.3909 + *
1.3910 + * If the variable command is executed inside a Tcl procedure, it
1.3911 + * creates a local variable linked to the newly-created namespace
1.3912 + * variable.
1.3913 + *
1.3914 + * Results:
1.3915 + * Returns TCL_OK if the variable is found or created. Returns
1.3916 + * TCL_ERROR if anything goes wrong.
1.3917 + *
1.3918 + * Side effects:
1.3919 + * If anything goes wrong, this procedure returns an error message
1.3920 + * as the result in the interpreter's result object.
1.3921 + *
1.3922 + *----------------------------------------------------------------------
1.3923 + */
1.3924 +
1.3925 +int
1.3926 +Tcl_VariableObjCmd(dummy, interp, objc, objv)
1.3927 + ClientData dummy; /* Not used. */
1.3928 + Tcl_Interp *interp; /* Current interpreter. */
1.3929 + int objc; /* Number of arguments. */
1.3930 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.3931 +{
1.3932 + Interp *iPtr = (Interp *) interp;
1.3933 + char *varName, *tail, *cp;
1.3934 + Var *varPtr, *arrayPtr;
1.3935 + Tcl_Obj *varValuePtr;
1.3936 + int i, result;
1.3937 + Tcl_Obj *varNamePtr;
1.3938 +
1.3939 + if (objc < 2) {
1.3940 + Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?");
1.3941 + return TCL_ERROR;
1.3942 + }
1.3943 +
1.3944 + for (i = 1; i < objc; i = i+2) {
1.3945 + /*
1.3946 + * Look up each variable in the current namespace context, creating
1.3947 + * it if necessary.
1.3948 + */
1.3949 +
1.3950 + varNamePtr = objv[i];
1.3951 + varName = TclGetString(varNamePtr);
1.3952 + varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
1.3953 + (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define",
1.3954 + /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
1.3955 +
1.3956 + if (arrayPtr != NULL) {
1.3957 + /*
1.3958 + * Variable cannot be an element in an array. If arrayPtr is
1.3959 + * non-null, it is, so throw up an error and return.
1.3960 + */
1.3961 + VarErrMsg(interp, varName, NULL, "define", isArrayElement);
1.3962 + return TCL_ERROR;
1.3963 + }
1.3964 +
1.3965 + if (varPtr == NULL) {
1.3966 + return TCL_ERROR;
1.3967 + }
1.3968 +
1.3969 + /*
1.3970 + * Mark the variable as a namespace variable and increment its
1.3971 + * reference count so that it will persist until its namespace is
1.3972 + * destroyed or until the variable is unset.
1.3973 + */
1.3974 +
1.3975 + if (!(varPtr->flags & VAR_NAMESPACE_VAR)) {
1.3976 + varPtr->flags |= VAR_NAMESPACE_VAR;
1.3977 + varPtr->refCount++;
1.3978 + }
1.3979 +
1.3980 + /*
1.3981 + * If a value was specified, set the variable to that value.
1.3982 + * Otherwise, if the variable is new, leave it undefined.
1.3983 + * (If the variable already exists and no value was specified,
1.3984 + * leave its value unchanged; just create the local link if
1.3985 + * we're in a Tcl procedure).
1.3986 + */
1.3987 +
1.3988 + if (i+1 < objc) { /* a value was specified */
1.3989 + varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varName, NULL,
1.3990 + objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG));
1.3991 + if (varValuePtr == NULL) {
1.3992 + return TCL_ERROR;
1.3993 + }
1.3994 + }
1.3995 +
1.3996 + /*
1.3997 + * If we are executing inside a Tcl procedure, create a local
1.3998 + * variable linked to the new namespace variable "varName".
1.3999 + */
1.4000 +
1.4001 + if ((iPtr->varFramePtr != NULL)
1.4002 + && iPtr->varFramePtr->isProcCallFrame) {
1.4003 + /*
1.4004 + * varName might have a scope qualifier, but the name for the
1.4005 + * local "link" variable must be the simple name at the tail.
1.4006 + *
1.4007 + * Locate tail in one pass: drop any prefix after two *or more*
1.4008 + * consecutive ":" characters).
1.4009 + */
1.4010 +
1.4011 + for (tail = cp = varName; *cp != '\0'; ) {
1.4012 + if (*cp++ == ':') {
1.4013 + while (*cp == ':') {
1.4014 + tail = ++cp;
1.4015 + }
1.4016 + }
1.4017 + }
1.4018 +
1.4019 + /*
1.4020 + * Create a local link "tail" to the variable "varName" in the
1.4021 + * current namespace.
1.4022 + */
1.4023 +
1.4024 + result = ObjMakeUpvar(interp, (CallFrame *) NULL,
1.4025 + /*otherP1*/ varNamePtr, /*otherP2*/ NULL,
1.4026 + /*otherFlags*/ TCL_NAMESPACE_ONLY,
1.4027 + /*myName*/ tail, /*myFlags*/ 0, -1);
1.4028 + if (result != TCL_OK) {
1.4029 + return result;
1.4030 + }
1.4031 + }
1.4032 + }
1.4033 + return TCL_OK;
1.4034 +}
1.4035 +
1.4036 +/*
1.4037 + *----------------------------------------------------------------------
1.4038 + *
1.4039 + * Tcl_UpvarObjCmd --
1.4040 + *
1.4041 + * This object-based procedure is invoked to process the "upvar"
1.4042 + * Tcl command. See the user documentation for details on what it does.
1.4043 + *
1.4044 + * Results:
1.4045 + * A standard Tcl object result value.
1.4046 + *
1.4047 + * Side effects:
1.4048 + * See the user documentation.
1.4049 + *
1.4050 + *----------------------------------------------------------------------
1.4051 + */
1.4052 +
1.4053 + /* ARGSUSED */
1.4054 +int
1.4055 +Tcl_UpvarObjCmd(dummy, interp, objc, objv)
1.4056 + ClientData dummy; /* Not used. */
1.4057 + Tcl_Interp *interp; /* Current interpreter. */
1.4058 + int objc; /* Number of arguments. */
1.4059 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.4060 +{
1.4061 + CallFrame *framePtr;
1.4062 + char *frameSpec, *localName;
1.4063 + int result;
1.4064 +
1.4065 + if (objc < 3) {
1.4066 + upvarSyntax:
1.4067 + Tcl_WrongNumArgs(interp, 1, objv,
1.4068 + "?level? otherVar localVar ?otherVar localVar ...?");
1.4069 + return TCL_ERROR;
1.4070 + }
1.4071 +
1.4072 + /*
1.4073 + * Find the call frame containing each of the "other variables" to be
1.4074 + * linked to.
1.4075 + */
1.4076 +
1.4077 + frameSpec = TclGetString(objv[1]);
1.4078 + result = TclGetFrame(interp, frameSpec, &framePtr);
1.4079 + if (result == -1) {
1.4080 + return TCL_ERROR;
1.4081 + }
1.4082 + objc -= result+1;
1.4083 + if ((objc & 1) != 0) {
1.4084 + goto upvarSyntax;
1.4085 + }
1.4086 + objv += result+1;
1.4087 +
1.4088 + /*
1.4089 + * Iterate over each (other variable, local variable) pair.
1.4090 + * Divide the other variable name into two parts, then call
1.4091 + * MakeUpvar to do all the work of linking it to the local variable.
1.4092 + */
1.4093 +
1.4094 + for ( ; objc > 0; objc -= 2, objv += 2) {
1.4095 + localName = TclGetString(objv[1]);
1.4096 + result = ObjMakeUpvar(interp, framePtr, /* othervarName */ objv[0],
1.4097 + NULL, 0, /* myVarName */ localName, /*flags*/ 0, -1);
1.4098 + if (result != TCL_OK) {
1.4099 + return TCL_ERROR;
1.4100 + }
1.4101 + }
1.4102 + return TCL_OK;
1.4103 +}
1.4104 +
1.4105 +/*
1.4106 + *----------------------------------------------------------------------
1.4107 + *
1.4108 + * DisposeTraceResult--
1.4109 + *
1.4110 + * This procedure is called to dispose of the result returned from
1.4111 + * a trace procedure. The disposal method appropriate to the type
1.4112 + * of result is determined by flags.
1.4113 + *
1.4114 + * Results:
1.4115 + * None.
1.4116 + *
1.4117 + * Side effects:
1.4118 + * The memory allocated for the trace result may be freed.
1.4119 + *
1.4120 + *----------------------------------------------------------------------
1.4121 + */
1.4122 +
1.4123 +static void
1.4124 +DisposeTraceResult(flags, result)
1.4125 + int flags; /* Indicates type of result to determine
1.4126 + * proper disposal method */
1.4127 + char *result; /* The result returned from a trace
1.4128 + * procedure to be disposed */
1.4129 +{
1.4130 + if (flags & TCL_TRACE_RESULT_DYNAMIC) {
1.4131 + ckfree(result);
1.4132 + } else if (flags & TCL_TRACE_RESULT_OBJECT) {
1.4133 + Tcl_DecrRefCount((Tcl_Obj *) result);
1.4134 + }
1.4135 +}
1.4136 +
1.4137 +/*
1.4138 + *----------------------------------------------------------------------
1.4139 + *
1.4140 + * CallVarTraces --
1.4141 + *
1.4142 + * This procedure is invoked to find and invoke relevant
1.4143 + * trace procedures associated with a particular operation on
1.4144 + * a variable. This procedure invokes traces both on the
1.4145 + * variable and on its containing array (where relevant).
1.4146 + *
1.4147 + * Results:
1.4148 + * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR
1.4149 + * if invocation of a trace procedure indicated an error. When
1.4150 + * TCL_ERROR is returned and leaveErrMsg is true, then the
1.4151 + * ::errorInfo variable of iPtr has information about the error
1.4152 + * appended to it.
1.4153 + *
1.4154 + * Side effects:
1.4155 + * Almost anything can happen, depending on trace; this procedure
1.4156 + * itself doesn't have any side effects.
1.4157 + *
1.4158 + *----------------------------------------------------------------------
1.4159 + */
1.4160 +
1.4161 +static int
1.4162 +CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
1.4163 + Interp *iPtr; /* Interpreter containing variable. */
1.4164 + register Var *arrayPtr; /* Pointer to array variable that contains
1.4165 + * the variable, or NULL if the variable
1.4166 + * isn't an element of an array. */
1.4167 + Var *varPtr; /* Variable whose traces are to be
1.4168 + * invoked. */
1.4169 + CONST char *part1;
1.4170 + CONST char *part2; /* Variable's two-part name. */
1.4171 + int flags; /* Flags passed to trace procedures:
1.4172 + * indicates what's happening to variable,
1.4173 + * plus other stuff like TCL_GLOBAL_ONLY,
1.4174 + * or TCL_NAMESPACE_ONLY. */
1.4175 + CONST int leaveErrMsg; /* If true, and one of the traces indicates an
1.4176 + * error, then leave an error message and stack
1.4177 + * trace information in *iPTr. */
1.4178 +{
1.4179 + register VarTrace *tracePtr;
1.4180 + ActiveVarTrace active;
1.4181 + char *result;
1.4182 + CONST char *openParen, *p;
1.4183 + Tcl_DString nameCopy;
1.4184 + int copiedName;
1.4185 + int code = TCL_OK;
1.4186 + int disposeFlags = 0;
1.4187 + int saveErrFlags = iPtr->flags
1.4188 + & (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET);
1.4189 +
1.4190 + /*
1.4191 + * If there are already similar trace procedures active for the
1.4192 + * variable, don't call them again.
1.4193 + */
1.4194 +
1.4195 + if (varPtr->flags & VAR_TRACE_ACTIVE) {
1.4196 + return code;
1.4197 + }
1.4198 + varPtr->flags |= VAR_TRACE_ACTIVE;
1.4199 + varPtr->refCount++;
1.4200 + if (arrayPtr != NULL) {
1.4201 + arrayPtr->refCount++;
1.4202 + }
1.4203 +
1.4204 + /*
1.4205 + * If the variable name hasn't been parsed into array name and
1.4206 + * element, do it here. If there really is an array element,
1.4207 + * make a copy of the original name so that NULLs can be
1.4208 + * inserted into it to separate the names (can't modify the name
1.4209 + * string in place, because the string might get used by the
1.4210 + * callbacks we invoke).
1.4211 + */
1.4212 +
1.4213 + copiedName = 0;
1.4214 + if (part2 == NULL) {
1.4215 + for (p = part1; *p ; p++) {
1.4216 + if (*p == '(') {
1.4217 + openParen = p;
1.4218 + do {
1.4219 + p++;
1.4220 + } while (*p != '\0');
1.4221 + p--;
1.4222 + if (*p == ')') {
1.4223 + int offset = (openParen - part1);
1.4224 + char *newPart1;
1.4225 + Tcl_DStringInit(&nameCopy);
1.4226 + Tcl_DStringAppend(&nameCopy, part1, (p-part1));
1.4227 + newPart1 = Tcl_DStringValue(&nameCopy);
1.4228 + newPart1[offset] = 0;
1.4229 + part1 = newPart1;
1.4230 + part2 = newPart1 + offset + 1;
1.4231 + copiedName = 1;
1.4232 + }
1.4233 + break;
1.4234 + }
1.4235 + }
1.4236 + }
1.4237 +
1.4238 + /*
1.4239 + * Invoke traces on the array containing the variable, if relevant.
1.4240 + */
1.4241 +
1.4242 + result = NULL;
1.4243 + active.nextPtr = iPtr->activeVarTracePtr;
1.4244 + iPtr->activeVarTracePtr = &active;
1.4245 + Tcl_Preserve((ClientData) iPtr);
1.4246 + if (arrayPtr != NULL && !(arrayPtr->flags & VAR_TRACE_ACTIVE)) {
1.4247 + active.varPtr = arrayPtr;
1.4248 + for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL;
1.4249 + tracePtr = active.nextTracePtr) {
1.4250 + active.nextTracePtr = tracePtr->nextPtr;
1.4251 + if (!(tracePtr->flags & flags)) {
1.4252 + continue;
1.4253 + }
1.4254 + Tcl_Preserve((ClientData) tracePtr);
1.4255 + if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
1.4256 + flags |= TCL_INTERP_DESTROYED;
1.4257 + }
1.4258 + result = (*tracePtr->traceProc)(tracePtr->clientData,
1.4259 + (Tcl_Interp *) iPtr, part1, part2, flags);
1.4260 + if (result != NULL) {
1.4261 + if (flags & TCL_TRACE_UNSETS) {
1.4262 + /* Ignore errors in unset traces */
1.4263 + DisposeTraceResult(tracePtr->flags, result);
1.4264 + } else {
1.4265 + disposeFlags = tracePtr->flags;
1.4266 + code = TCL_ERROR;
1.4267 + }
1.4268 + }
1.4269 + Tcl_Release((ClientData) tracePtr);
1.4270 + if (code == TCL_ERROR) {
1.4271 + goto done;
1.4272 + }
1.4273 + }
1.4274 + }
1.4275 +
1.4276 + /*
1.4277 + * Invoke traces on the variable itself.
1.4278 + */
1.4279 +
1.4280 + if (flags & TCL_TRACE_UNSETS) {
1.4281 + flags |= TCL_TRACE_DESTROYED;
1.4282 + }
1.4283 + active.varPtr = varPtr;
1.4284 + for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
1.4285 + tracePtr = active.nextTracePtr) {
1.4286 + active.nextTracePtr = tracePtr->nextPtr;
1.4287 + if (!(tracePtr->flags & flags)) {
1.4288 + continue;
1.4289 + }
1.4290 + Tcl_Preserve((ClientData) tracePtr);
1.4291 + if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
1.4292 + flags |= TCL_INTERP_DESTROYED;
1.4293 + }
1.4294 + result = (*tracePtr->traceProc)(tracePtr->clientData,
1.4295 + (Tcl_Interp *) iPtr, part1, part2, flags);
1.4296 + if (result != NULL) {
1.4297 + if (flags & TCL_TRACE_UNSETS) {
1.4298 + /* Ignore errors in unset traces */
1.4299 + DisposeTraceResult(tracePtr->flags, result);
1.4300 + } else {
1.4301 + disposeFlags = tracePtr->flags;
1.4302 + code = TCL_ERROR;
1.4303 + }
1.4304 + }
1.4305 + Tcl_Release((ClientData) tracePtr);
1.4306 + if (code == TCL_ERROR) {
1.4307 + goto done;
1.4308 + }
1.4309 + }
1.4310 +
1.4311 + /*
1.4312 + * Restore the variable's flags, remove the record of our active
1.4313 + * traces, and then return.
1.4314 + */
1.4315 +
1.4316 + done:
1.4317 + if (code == TCL_OK) {
1.4318 + iPtr->flags |= saveErrFlags;
1.4319 + }
1.4320 + if (code == TCL_ERROR) {
1.4321 + if (leaveErrMsg) {
1.4322 + CONST char *type = "";
1.4323 + switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) {
1.4324 + case TCL_TRACE_READS: {
1.4325 + type = "read";
1.4326 + break;
1.4327 + }
1.4328 + case TCL_TRACE_WRITES: {
1.4329 + type = "set";
1.4330 + break;
1.4331 + }
1.4332 + case TCL_TRACE_ARRAY: {
1.4333 + type = "trace array";
1.4334 + break;
1.4335 + }
1.4336 + }
1.4337 + if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
1.4338 + VarErrMsg((Tcl_Interp *) iPtr, part1, part2, type,
1.4339 + Tcl_GetString((Tcl_Obj *) result));
1.4340 + } else {
1.4341 + VarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, result);
1.4342 + }
1.4343 + }
1.4344 + DisposeTraceResult(disposeFlags,result);
1.4345 + }
1.4346 +
1.4347 + if (arrayPtr != NULL) {
1.4348 + arrayPtr->refCount--;
1.4349 + }
1.4350 + if (copiedName) {
1.4351 + Tcl_DStringFree(&nameCopy);
1.4352 + }
1.4353 + varPtr->flags &= ~VAR_TRACE_ACTIVE;
1.4354 + varPtr->refCount--;
1.4355 + iPtr->activeVarTracePtr = active.nextPtr;
1.4356 + Tcl_Release((ClientData) iPtr);
1.4357 + return code;
1.4358 +}
1.4359 +
1.4360 +/*
1.4361 + *----------------------------------------------------------------------
1.4362 + *
1.4363 + * NewVar --
1.4364 + *
1.4365 + * Create a new heap-allocated variable that will eventually be
1.4366 + * entered into a hashtable.
1.4367 + *
1.4368 + * Results:
1.4369 + * The return value is a pointer to the new variable structure. It is
1.4370 + * marked as a scalar variable (and not a link or array variable). Its
1.4371 + * value initially is NULL. The variable is not part of any hash table
1.4372 + * yet. Since it will be in a hashtable and not in a call frame, its
1.4373 + * name field is set NULL. It is initially marked as undefined.
1.4374 + *
1.4375 + * Side effects:
1.4376 + * Storage gets allocated.
1.4377 + *
1.4378 + *----------------------------------------------------------------------
1.4379 + */
1.4380 +
1.4381 +static Var *
1.4382 +NewVar()
1.4383 +{
1.4384 + register Var *varPtr;
1.4385 +
1.4386 + varPtr = (Var *) ckalloc(sizeof(Var));
1.4387 + varPtr->value.objPtr = NULL;
1.4388 + varPtr->name = NULL;
1.4389 + varPtr->nsPtr = NULL;
1.4390 + varPtr->hPtr = NULL;
1.4391 + varPtr->refCount = 0;
1.4392 + varPtr->tracePtr = NULL;
1.4393 + varPtr->searchPtr = NULL;
1.4394 + varPtr->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE);
1.4395 + return varPtr;
1.4396 +}
1.4397 +
1.4398 +/*
1.4399 + *----------------------------------------------------------------------
1.4400 + *
1.4401 + * SetArraySearchObj --
1.4402 + *
1.4403 + * This function converts the given tcl object into one that
1.4404 + * has the "array search" internal type.
1.4405 + *
1.4406 + * Results:
1.4407 + * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed
1.4408 + * (when an error message will be placed in the interpreter's
1.4409 + * result.)
1.4410 + *
1.4411 + * Side effects:
1.4412 + * Updates the internal type and representation of the object to
1.4413 + * make this an array-search object. See the tclArraySearchType
1.4414 + * declaration above for details of the internal representation.
1.4415 + *
1.4416 + *----------------------------------------------------------------------
1.4417 + */
1.4418 +
1.4419 +static int
1.4420 +SetArraySearchObj(interp, objPtr)
1.4421 + Tcl_Interp *interp;
1.4422 + Tcl_Obj *objPtr;
1.4423 +{
1.4424 + char *string;
1.4425 + char *end;
1.4426 + int id;
1.4427 + size_t offset;
1.4428 +
1.4429 + /*
1.4430 + * Get the string representation. Make it up-to-date if necessary.
1.4431 + */
1.4432 +
1.4433 + string = Tcl_GetString(objPtr);
1.4434 +
1.4435 + /*
1.4436 + * Parse the id into the three parts separated by dashes.
1.4437 + */
1.4438 + if ((string[0] != 's') || (string[1] != '-')) {
1.4439 + syntax:
1.4440 + Tcl_AppendResult(interp, "illegal search identifier \"", string,
1.4441 + "\"", (char *) NULL);
1.4442 + return TCL_ERROR;
1.4443 + }
1.4444 + id = strtoul(string+2, &end, 10);
1.4445 + if ((end == (string+2)) || (*end != '-')) {
1.4446 + goto syntax;
1.4447 + }
1.4448 + /*
1.4449 + * Can't perform value check in this context, so place reference
1.4450 + * to place in string to use for the check in the object instead.
1.4451 + */
1.4452 + end++;
1.4453 + offset = end - string;
1.4454 +
1.4455 + if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) {
1.4456 + objPtr->typePtr->freeIntRepProc(objPtr);
1.4457 + }
1.4458 + objPtr->typePtr = &tclArraySearchType;
1.4459 + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *)(((char *)NULL)+id);
1.4460 + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *)(((char *)NULL)+offset);
1.4461 + return TCL_OK;
1.4462 +}
1.4463 +
1.4464 +/*
1.4465 + *----------------------------------------------------------------------
1.4466 + *
1.4467 + * ParseSearchId --
1.4468 + *
1.4469 + * This procedure translates from a tcl object to a pointer to an
1.4470 + * active array search (if there is one that matches the string).
1.4471 + *
1.4472 + * Results:
1.4473 + * The return value is a pointer to the array search indicated
1.4474 + * by string, or NULL if there isn't one. If NULL is returned,
1.4475 + * the interp's result contains an error message.
1.4476 + *
1.4477 + * Side effects:
1.4478 + * The tcl object might have its internal type and representation
1.4479 + * modified.
1.4480 + *
1.4481 + *----------------------------------------------------------------------
1.4482 + */
1.4483 +
1.4484 +static ArraySearch *
1.4485 +ParseSearchId(interp, varPtr, varName, handleObj)
1.4486 + Tcl_Interp *interp; /* Interpreter containing variable. */
1.4487 + CONST Var *varPtr; /* Array variable search is for. */
1.4488 + CONST char *varName; /* Name of array variable that search is
1.4489 + * supposed to be for. */
1.4490 + Tcl_Obj *handleObj; /* Object containing id of search. Must have
1.4491 + * form "search-num-var" where "num" is a
1.4492 + * decimal number and "var" is a variable
1.4493 + * name. */
1.4494 +{
1.4495 + register char *string;
1.4496 + register size_t offset;
1.4497 + int id;
1.4498 + ArraySearch *searchPtr;
1.4499 +
1.4500 + /*
1.4501 + * Parse the id.
1.4502 + */
1.4503 + if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) {
1.4504 + return NULL;
1.4505 + }
1.4506 + /*
1.4507 + * Cast is safe, since always came from an int in the first place.
1.4508 + */
1.4509 + id = (int)(((char*)handleObj->internalRep.twoPtrValue.ptr1) -
1.4510 + ((char*)NULL));
1.4511 + string = Tcl_GetString(handleObj);
1.4512 + offset = (((char*)handleObj->internalRep.twoPtrValue.ptr2) -
1.4513 + ((char*)NULL));
1.4514 + /*
1.4515 + * This test cannot be placed inside the Tcl_Obj machinery, since
1.4516 + * it is dependent on the variable context.
1.4517 + */
1.4518 + if (strcmp(string+offset, varName) != 0) {
1.4519 + Tcl_AppendResult(interp, "search identifier \"", string,
1.4520 + "\" isn't for variable \"", varName, "\"", (char *) NULL);
1.4521 + return NULL;
1.4522 + }
1.4523 +
1.4524 + /*
1.4525 + * Search through the list of active searches on the interpreter
1.4526 + * to see if the desired one exists.
1.4527 + *
1.4528 + * Note that we cannot store the searchPtr directly in the Tcl_Obj
1.4529 + * as that would run into trouble when DeleteSearches() was called
1.4530 + * so we must scan this list every time.
1.4531 + */
1.4532 +
1.4533 + for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
1.4534 + searchPtr = searchPtr->nextPtr) {
1.4535 + if (searchPtr->id == id) {
1.4536 + return searchPtr;
1.4537 + }
1.4538 + }
1.4539 + Tcl_AppendResult(interp, "couldn't find search \"", string, "\"",
1.4540 + (char *) NULL);
1.4541 + return NULL;
1.4542 +}
1.4543 +
1.4544 +/*
1.4545 + *----------------------------------------------------------------------
1.4546 + *
1.4547 + * DeleteSearches --
1.4548 + *
1.4549 + * This procedure is called to free up all of the searches
1.4550 + * associated with an array variable.
1.4551 + *
1.4552 + * Results:
1.4553 + * None.
1.4554 + *
1.4555 + * Side effects:
1.4556 + * Memory is released to the storage allocator.
1.4557 + *
1.4558 + *----------------------------------------------------------------------
1.4559 + */
1.4560 +
1.4561 +static void
1.4562 +DeleteSearches(arrayVarPtr)
1.4563 + register Var *arrayVarPtr; /* Variable whose searches are
1.4564 + * to be deleted. */
1.4565 +{
1.4566 + ArraySearch *searchPtr;
1.4567 +
1.4568 + while (arrayVarPtr->searchPtr != NULL) {
1.4569 + searchPtr = arrayVarPtr->searchPtr;
1.4570 + arrayVarPtr->searchPtr = searchPtr->nextPtr;
1.4571 + ckfree((char *) searchPtr);
1.4572 + }
1.4573 +}
1.4574 +
1.4575 +/*
1.4576 + *----------------------------------------------------------------------
1.4577 + *
1.4578 + * TclDeleteNamespaceVars --
1.4579 + *
1.4580 + * This procedure is called to recycle all the storage space
1.4581 + * associated with a namespace's table of variables.
1.4582 + *
1.4583 + * Results:
1.4584 + * None.
1.4585 + *
1.4586 + * Side effects:
1.4587 + * Variables are deleted and trace procedures are invoked, if
1.4588 + * any are declared.
1.4589 + *
1.4590 + *----------------------------------------------------------------------
1.4591 + */
1.4592 +
1.4593 +void
1.4594 +TclDeleteNamespaceVars(nsPtr)
1.4595 + Namespace *nsPtr;
1.4596 +{
1.4597 + Tcl_HashTable *tablePtr = &nsPtr->varTable;
1.4598 + Tcl_Interp *interp = nsPtr->interp;
1.4599 + Interp *iPtr = (Interp *)interp;
1.4600 + Tcl_HashSearch search;
1.4601 + Tcl_HashEntry *hPtr;
1.4602 + int flags = 0;
1.4603 + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1.4604 +
1.4605 + /*
1.4606 + * Determine what flags to pass to the trace callback procedures.
1.4607 + */
1.4608 +
1.4609 + if (nsPtr == iPtr->globalNsPtr) {
1.4610 + flags = TCL_GLOBAL_ONLY;
1.4611 + } else if (nsPtr == currNsPtr) {
1.4612 + flags = TCL_NAMESPACE_ONLY;
1.4613 + }
1.4614 +
1.4615 + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
1.4616 + hPtr = Tcl_FirstHashEntry(tablePtr, &search)) {
1.4617 + register Var *varPtr = (Var *) Tcl_GetHashValue(hPtr);
1.4618 + Tcl_Obj *objPtr = Tcl_NewObj();
1.4619 + varPtr->refCount++; /* Make sure we get to remove from hash */
1.4620 + Tcl_IncrRefCount(objPtr);
1.4621 + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
1.4622 + UnsetVarStruct(varPtr, NULL, iPtr, Tcl_GetString(objPtr), NULL, flags);
1.4623 + Tcl_DecrRefCount(objPtr); /* free no longer needed obj */
1.4624 + varPtr->refCount--;
1.4625 +
1.4626 + /* Remove the variable from the table and force it undefined
1.4627 + * in case an unset trace brought it back from the dead */
1.4628 + Tcl_DeleteHashEntry(hPtr);
1.4629 + varPtr->hPtr = NULL;
1.4630 + TclSetVarUndefined(varPtr);
1.4631 + TclSetVarScalar(varPtr);
1.4632 + while (varPtr->tracePtr != NULL) {
1.4633 + VarTrace *tracePtr = varPtr->tracePtr;
1.4634 + varPtr->tracePtr = tracePtr->nextPtr;
1.4635 + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
1.4636 + }
1.4637 + CleanupVar(varPtr, NULL);
1.4638 + }
1.4639 + Tcl_DeleteHashTable(tablePtr);
1.4640 +}
1.4641 +
1.4642 +
1.4643 +/*
1.4644 + *----------------------------------------------------------------------
1.4645 + *
1.4646 + * TclDeleteVars --
1.4647 + *
1.4648 + * This procedure is called to recycle all the storage space
1.4649 + * associated with a table of variables. For this procedure
1.4650 + * to work correctly, it must not be possible for any of the
1.4651 + * variables in the table to be accessed from Tcl commands
1.4652 + * (e.g. from trace procedures).
1.4653 + *
1.4654 + * Results:
1.4655 + * None.
1.4656 + *
1.4657 + * Side effects:
1.4658 + * Variables are deleted and trace procedures are invoked, if
1.4659 + * any are declared.
1.4660 + *
1.4661 + *----------------------------------------------------------------------
1.4662 + */
1.4663 +
1.4664 +void
1.4665 +TclDeleteVars(iPtr, tablePtr)
1.4666 + Interp *iPtr; /* Interpreter to which variables belong. */
1.4667 + Tcl_HashTable *tablePtr; /* Hash table containing variables to
1.4668 + * delete. */
1.4669 +{
1.4670 + Tcl_Interp *interp = (Tcl_Interp *) iPtr;
1.4671 + Tcl_HashSearch search;
1.4672 + Tcl_HashEntry *hPtr;
1.4673 + register Var *varPtr;
1.4674 + Var *linkPtr;
1.4675 + int flags;
1.4676 + ActiveVarTrace *activePtr;
1.4677 + Tcl_Obj *objPtr;
1.4678 + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1.4679 +
1.4680 + /*
1.4681 + * Determine what flags to pass to the trace callback procedures.
1.4682 + */
1.4683 +
1.4684 + flags = TCL_TRACE_UNSETS;
1.4685 + if (tablePtr == &iPtr->globalNsPtr->varTable) {
1.4686 + flags |= TCL_GLOBAL_ONLY;
1.4687 + } else if (tablePtr == &currNsPtr->varTable) {
1.4688 + flags |= TCL_NAMESPACE_ONLY;
1.4689 + }
1.4690 +
1.4691 + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
1.4692 + hPtr = Tcl_NextHashEntry(&search)) {
1.4693 + varPtr = (Var *) Tcl_GetHashValue(hPtr);
1.4694 +
1.4695 + /*
1.4696 + * For global/upvar variables referenced in procedures, decrement
1.4697 + * the reference count on the variable referred to, and free
1.4698 + * the referenced variable if it's no longer needed. Don't delete
1.4699 + * the hash entry for the other variable if it's in the same table
1.4700 + * as us: this will happen automatically later on.
1.4701 + */
1.4702 +
1.4703 + if (TclIsVarLink(varPtr)) {
1.4704 + linkPtr = varPtr->value.linkPtr;
1.4705 + linkPtr->refCount--;
1.4706 + if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr)
1.4707 + && (linkPtr->tracePtr == NULL)
1.4708 + && (linkPtr->flags & VAR_IN_HASHTABLE)) {
1.4709 + if (linkPtr->hPtr == NULL) {
1.4710 + ckfree((char *) linkPtr);
1.4711 + } else if (linkPtr->hPtr->tablePtr != tablePtr) {
1.4712 + Tcl_DeleteHashEntry(linkPtr->hPtr);
1.4713 + ckfree((char *) linkPtr);
1.4714 + }
1.4715 + }
1.4716 + }
1.4717 +
1.4718 + /*
1.4719 + * Invoke traces on the variable that is being deleted, then
1.4720 + * free up the variable's space (no need to free the hash entry
1.4721 + * here, unless we're dealing with a global variable: the
1.4722 + * hash entries will be deleted automatically when the whole
1.4723 + * table is deleted). Note that we give CallVarTraces the variable's
1.4724 + * fully-qualified name so that any called trace procedures can
1.4725 + * refer to these variables being deleted.
1.4726 + */
1.4727 +
1.4728 + if (varPtr->tracePtr != NULL) {
1.4729 + objPtr = Tcl_NewObj();
1.4730 + Tcl_IncrRefCount(objPtr); /* until done with traces */
1.4731 + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
1.4732 + CallVarTraces(iPtr, (Var *) NULL, varPtr, Tcl_GetString(objPtr),
1.4733 + NULL, flags, /* leaveErrMsg */ 0);
1.4734 + Tcl_DecrRefCount(objPtr); /* free no longer needed obj */
1.4735 +
1.4736 + while (varPtr->tracePtr != NULL) {
1.4737 + VarTrace *tracePtr = varPtr->tracePtr;
1.4738 + varPtr->tracePtr = tracePtr->nextPtr;
1.4739 + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
1.4740 + }
1.4741 + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
1.4742 + activePtr = activePtr->nextPtr) {
1.4743 + if (activePtr->varPtr == varPtr) {
1.4744 + activePtr->nextTracePtr = NULL;
1.4745 + }
1.4746 + }
1.4747 + }
1.4748 +
1.4749 + if (TclIsVarArray(varPtr)) {
1.4750 + DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr,
1.4751 + flags);
1.4752 + varPtr->value.tablePtr = NULL;
1.4753 + }
1.4754 + if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) {
1.4755 + objPtr = varPtr->value.objPtr;
1.4756 + TclDecrRefCount(objPtr);
1.4757 + varPtr->value.objPtr = NULL;
1.4758 + }
1.4759 + varPtr->hPtr = NULL;
1.4760 + varPtr->tracePtr = NULL;
1.4761 + TclSetVarUndefined(varPtr);
1.4762 + TclSetVarScalar(varPtr);
1.4763 +
1.4764 + /*
1.4765 + * If the variable was a namespace variable, decrement its
1.4766 + * reference count. We are in the process of destroying its
1.4767 + * namespace so that namespace will no longer "refer" to the
1.4768 + * variable.
1.4769 + */
1.4770 +
1.4771 + if (varPtr->flags & VAR_NAMESPACE_VAR) {
1.4772 + varPtr->flags &= ~VAR_NAMESPACE_VAR;
1.4773 + varPtr->refCount--;
1.4774 + }
1.4775 +
1.4776 + /*
1.4777 + * Recycle the variable's memory space if there aren't any upvar's
1.4778 + * pointing to it. If there are upvars to this variable, then the
1.4779 + * variable will get freed when the last upvar goes away.
1.4780 + */
1.4781 +
1.4782 + if (varPtr->refCount == 0) {
1.4783 + ckfree((char *) varPtr); /* this Var must be VAR_IN_HASHTABLE */
1.4784 + }
1.4785 + }
1.4786 + Tcl_DeleteHashTable(tablePtr);
1.4787 +}
1.4788 +
1.4789 +/*
1.4790 + *----------------------------------------------------------------------
1.4791 + *
1.4792 + * TclDeleteCompiledLocalVars --
1.4793 + *
1.4794 + * This procedure is called to recycle storage space associated with
1.4795 + * the compiler-allocated array of local variables in a procedure call
1.4796 + * frame. This procedure resembles TclDeleteVars above except that each
1.4797 + * variable is stored in a call frame and not a hash table. For this
1.4798 + * procedure to work correctly, it must not be possible for any of the
1.4799 + * variable in the table to be accessed from Tcl commands (e.g. from
1.4800 + * trace procedures).
1.4801 + *
1.4802 + * Results:
1.4803 + * None.
1.4804 + *
1.4805 + * Side effects:
1.4806 + * Variables are deleted and trace procedures are invoked, if
1.4807 + * any are declared.
1.4808 + *
1.4809 + *----------------------------------------------------------------------
1.4810 + */
1.4811 +
1.4812 +void
1.4813 +TclDeleteCompiledLocalVars(iPtr, framePtr)
1.4814 + Interp *iPtr; /* Interpreter to which variables belong. */
1.4815 + CallFrame *framePtr; /* Procedure call frame containing
1.4816 + * compiler-assigned local variables to
1.4817 + * delete. */
1.4818 +{
1.4819 + register Var *varPtr;
1.4820 + int flags; /* Flags passed to trace procedures. */
1.4821 + Var *linkPtr;
1.4822 + ActiveVarTrace *activePtr;
1.4823 + int numLocals, i;
1.4824 +
1.4825 + flags = TCL_TRACE_UNSETS;
1.4826 + numLocals = framePtr->numCompiledLocals;
1.4827 + varPtr = framePtr->compiledLocals;
1.4828 + for (i = 0; i < numLocals; i++) {
1.4829 + /*
1.4830 + * For global/upvar variables referenced in procedures, decrement
1.4831 + * the reference count on the variable referred to, and free
1.4832 + * the referenced variable if it's no longer needed. Don't delete
1.4833 + * the hash entry for the other variable if it's in the same table
1.4834 + * as us: this will happen automatically later on.
1.4835 + */
1.4836 +
1.4837 + if (TclIsVarLink(varPtr)) {
1.4838 + linkPtr = varPtr->value.linkPtr;
1.4839 + linkPtr->refCount--;
1.4840 + if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr)
1.4841 + && (linkPtr->tracePtr == NULL)
1.4842 + && (linkPtr->flags & VAR_IN_HASHTABLE)) {
1.4843 + if (linkPtr->hPtr == NULL) {
1.4844 + ckfree((char *) linkPtr);
1.4845 + } else {
1.4846 + Tcl_DeleteHashEntry(linkPtr->hPtr);
1.4847 + ckfree((char *) linkPtr);
1.4848 + }
1.4849 + }
1.4850 + }
1.4851 +
1.4852 + /*
1.4853 + * Invoke traces on the variable that is being deleted. Then delete
1.4854 + * the variable's trace records.
1.4855 + */
1.4856 +
1.4857 + if (varPtr->tracePtr != NULL) {
1.4858 + CallVarTraces(iPtr, (Var *) NULL, varPtr, varPtr->name, NULL,
1.4859 + flags, /* leaveErrMsg */ 0);
1.4860 + while (varPtr->tracePtr != NULL) {
1.4861 + VarTrace *tracePtr = varPtr->tracePtr;
1.4862 + varPtr->tracePtr = tracePtr->nextPtr;
1.4863 + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
1.4864 + }
1.4865 + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
1.4866 + activePtr = activePtr->nextPtr) {
1.4867 + if (activePtr->varPtr == varPtr) {
1.4868 + activePtr->nextTracePtr = NULL;
1.4869 + }
1.4870 + }
1.4871 + }
1.4872 +
1.4873 + /*
1.4874 + * Now if the variable is an array, delete its element hash table.
1.4875 + * Otherwise, if it's a scalar variable, decrement the ref count
1.4876 + * of its value.
1.4877 + */
1.4878 +
1.4879 + if (TclIsVarArray(varPtr) && (varPtr->value.tablePtr != NULL)) {
1.4880 + DeleteArray(iPtr, varPtr->name, varPtr, flags);
1.4881 + }
1.4882 + if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) {
1.4883 + TclDecrRefCount(varPtr->value.objPtr);
1.4884 + varPtr->value.objPtr = NULL;
1.4885 + }
1.4886 + varPtr->hPtr = NULL;
1.4887 + varPtr->tracePtr = NULL;
1.4888 + TclSetVarUndefined(varPtr);
1.4889 + TclSetVarScalar(varPtr);
1.4890 + varPtr++;
1.4891 + }
1.4892 +}
1.4893 +
1.4894 +/*
1.4895 + *----------------------------------------------------------------------
1.4896 + *
1.4897 + * DeleteArray --
1.4898 + *
1.4899 + * This procedure is called to free up everything in an array
1.4900 + * variable. It's the caller's responsibility to make sure
1.4901 + * that the array is no longer accessible before this procedure
1.4902 + * is called.
1.4903 + *
1.4904 + * Results:
1.4905 + * None.
1.4906 + *
1.4907 + * Side effects:
1.4908 + * All storage associated with varPtr's array elements is deleted
1.4909 + * (including the array's hash table). Deletion trace procedures for
1.4910 + * array elements are invoked, then deleted. Any pending traces for
1.4911 + * array elements are also deleted.
1.4912 + *
1.4913 + *----------------------------------------------------------------------
1.4914 + */
1.4915 +
1.4916 +static void
1.4917 +DeleteArray(iPtr, arrayName, varPtr, flags)
1.4918 + Interp *iPtr; /* Interpreter containing array. */
1.4919 + CONST char *arrayName; /* Name of array (used for trace
1.4920 + * callbacks). */
1.4921 + Var *varPtr; /* Pointer to variable structure. */
1.4922 + int flags; /* Flags to pass to CallVarTraces:
1.4923 + * TCL_TRACE_UNSETS and sometimes
1.4924 + * TCL_NAMESPACE_ONLY, or
1.4925 + * TCL_GLOBAL_ONLY. */
1.4926 +{
1.4927 + Tcl_HashSearch search;
1.4928 + register Tcl_HashEntry *hPtr;
1.4929 + register Var *elPtr;
1.4930 + ActiveVarTrace *activePtr;
1.4931 + Tcl_Obj *objPtr;
1.4932 +
1.4933 + DeleteSearches(varPtr);
1.4934 + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
1.4935 + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
1.4936 + elPtr = (Var *) Tcl_GetHashValue(hPtr);
1.4937 + if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) {
1.4938 + objPtr = elPtr->value.objPtr;
1.4939 + TclDecrRefCount(objPtr);
1.4940 + elPtr->value.objPtr = NULL;
1.4941 + }
1.4942 + elPtr->hPtr = NULL;
1.4943 + if (elPtr->tracePtr != NULL) {
1.4944 + elPtr->flags &= ~VAR_TRACE_ACTIVE;
1.4945 + CallVarTraces(iPtr, (Var *) NULL, elPtr, arrayName,
1.4946 + Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags,
1.4947 + /* leaveErrMsg */ 0);
1.4948 + while (elPtr->tracePtr != NULL) {
1.4949 + VarTrace *tracePtr = elPtr->tracePtr;
1.4950 + elPtr->tracePtr = tracePtr->nextPtr;
1.4951 + Tcl_EventuallyFree((ClientData) tracePtr,TCL_DYNAMIC);
1.4952 + }
1.4953 + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
1.4954 + activePtr = activePtr->nextPtr) {
1.4955 + if (activePtr->varPtr == elPtr) {
1.4956 + activePtr->nextTracePtr = NULL;
1.4957 + }
1.4958 + }
1.4959 + }
1.4960 + TclSetVarUndefined(elPtr);
1.4961 + TclSetVarScalar(elPtr);
1.4962 +
1.4963 + /*
1.4964 + * Even though array elements are not supposed to be namespace
1.4965 + * variables, some combinations of [upvar] and [variable] may
1.4966 + * create such beasts - see [Bug 604239]. This is necessary to
1.4967 + * avoid leaking the corresponding Var struct, and is otherwise
1.4968 + * harmless.
1.4969 + */
1.4970 +
1.4971 + if (elPtr->flags & VAR_NAMESPACE_VAR) {
1.4972 + elPtr->flags &= ~VAR_NAMESPACE_VAR;
1.4973 + elPtr->refCount--;
1.4974 + }
1.4975 + if (elPtr->refCount == 0) {
1.4976 + ckfree((char *) elPtr); /* element Vars are VAR_IN_HASHTABLE */
1.4977 + }
1.4978 + }
1.4979 + Tcl_DeleteHashTable(varPtr->value.tablePtr);
1.4980 + ckfree((char *) varPtr->value.tablePtr);
1.4981 +}
1.4982 +
1.4983 +/*
1.4984 + *----------------------------------------------------------------------
1.4985 + *
1.4986 + * CleanupVar --
1.4987 + *
1.4988 + * This procedure is called when it looks like it may be OK to free up
1.4989 + * a variable's storage. If the variable is in a hashtable, its Var
1.4990 + * structure and hash table entry will be freed along with those of its
1.4991 + * containing array, if any. This procedure is called, for example,
1.4992 + * when a trace on a variable deletes a variable.
1.4993 + *
1.4994 + * Results:
1.4995 + * None.
1.4996 + *
1.4997 + * Side effects:
1.4998 + * If the variable (or its containing array) really is dead and in a
1.4999 + * hashtable, then its Var structure, and possibly its hash table
1.5000 + * entry, is freed up.
1.5001 + *
1.5002 + *----------------------------------------------------------------------
1.5003 + */
1.5004 +
1.5005 +static void
1.5006 +CleanupVar(varPtr, arrayPtr)
1.5007 + Var *varPtr; /* Pointer to variable that may be a
1.5008 + * candidate for being expunged. */
1.5009 + Var *arrayPtr; /* Array that contains the variable, or
1.5010 + * NULL if this variable isn't an array
1.5011 + * element. */
1.5012 +{
1.5013 + if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)
1.5014 + && (varPtr->tracePtr == NULL)
1.5015 + && (varPtr->flags & VAR_IN_HASHTABLE)) {
1.5016 + if (varPtr->hPtr != NULL) {
1.5017 + Tcl_DeleteHashEntry(varPtr->hPtr);
1.5018 + }
1.5019 + ckfree((char *) varPtr);
1.5020 + }
1.5021 + if (arrayPtr != NULL) {
1.5022 + if (TclIsVarUndefined(arrayPtr) && (arrayPtr->refCount == 0)
1.5023 + && (arrayPtr->tracePtr == NULL)
1.5024 + && (arrayPtr->flags & VAR_IN_HASHTABLE)) {
1.5025 + if (arrayPtr->hPtr != NULL) {
1.5026 + Tcl_DeleteHashEntry(arrayPtr->hPtr);
1.5027 + }
1.5028 + ckfree((char *) arrayPtr);
1.5029 + }
1.5030 + }
1.5031 +}
1.5032 +/*
1.5033 + *----------------------------------------------------------------------
1.5034 + *
1.5035 + * VarErrMsg --
1.5036 + *
1.5037 + * Generate a reasonable error message describing why a variable
1.5038 + * operation failed.
1.5039 + *
1.5040 + * Results:
1.5041 + * None.
1.5042 + *
1.5043 + * Side effects:
1.5044 + * The interp's result is set to hold a message identifying the
1.5045 + * variable given by part1 and part2 and describing why the
1.5046 + * variable operation failed.
1.5047 + *
1.5048 + *----------------------------------------------------------------------
1.5049 + */
1.5050 +
1.5051 +static void
1.5052 +VarErrMsg(interp, part1, part2, operation, reason)
1.5053 + Tcl_Interp *interp; /* Interpreter in which to record message. */
1.5054 + CONST char *part1;
1.5055 + CONST char *part2; /* Variable's two-part name. */
1.5056 + CONST char *operation; /* String describing operation that failed,
1.5057 + * e.g. "read", "set", or "unset". */
1.5058 + CONST char *reason; /* String describing why operation failed. */
1.5059 +{
1.5060 + Tcl_ResetResult(interp);
1.5061 + Tcl_AppendResult(interp, "can't ", operation, " \"", part1,
1.5062 + (char *) NULL);
1.5063 + if (part2 != NULL) {
1.5064 + Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL);
1.5065 + }
1.5066 + Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
1.5067 +}
1.5068 +
1.5069 +/*
1.5070 + *----------------------------------------------------------------------
1.5071 + *
1.5072 + * TclTraceVarExists --
1.5073 + *
1.5074 + * This is called from info exists. We need to trigger read
1.5075 + * and/or array traces because they may end up creating a
1.5076 + * variable that doesn't currently exist.
1.5077 + *
1.5078 + * Results:
1.5079 + * A pointer to the Var structure, or NULL.
1.5080 + *
1.5081 + * Side effects:
1.5082 + * May fill in error messages in the interp.
1.5083 + *
1.5084 + *----------------------------------------------------------------------
1.5085 + */
1.5086 +
1.5087 +Var *
1.5088 +TclVarTraceExists(interp, varName)
1.5089 + Tcl_Interp *interp; /* The interpreter */
1.5090 + CONST char *varName; /* The variable name */
1.5091 +{
1.5092 + Var *varPtr;
1.5093 + Var *arrayPtr;
1.5094 +
1.5095 + /*
1.5096 + * The choice of "create" flag values is delicate here, and
1.5097 + * matches the semantics of GetVar. Things are still not perfect,
1.5098 + * however, because if you do "info exists x" you get a varPtr
1.5099 + * and therefore trigger traces. However, if you do
1.5100 + * "info exists x(i)", then you only get a varPtr if x is already
1.5101 + * known to be an array. Otherwise you get NULL, and no trace
1.5102 + * is triggered. This matches Tcl 7.6 semantics.
1.5103 + */
1.5104 +
1.5105 + varPtr = TclLookupVar(interp, varName, (char *) NULL,
1.5106 + 0, "access", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
1.5107 +
1.5108 + if (varPtr == NULL) {
1.5109 + return NULL;
1.5110 + }
1.5111 +
1.5112 + if ((varPtr->tracePtr != NULL)
1.5113 + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
1.5114 + CallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL,
1.5115 + TCL_TRACE_READS, /* leaveErrMsg */ 0);
1.5116 + }
1.5117 +
1.5118 + /*
1.5119 + * If the variable doesn't exist anymore and no-one's using
1.5120 + * it, then free up the relevant structures and hash table entries.
1.5121 + */
1.5122 +
1.5123 + if (TclIsVarUndefined(varPtr)) {
1.5124 + CleanupVar(varPtr, arrayPtr);
1.5125 + return NULL;
1.5126 + }
1.5127 +
1.5128 + return varPtr;
1.5129 +}
1.5130 +
1.5131 +/*
1.5132 + *----------------------------------------------------------------------
1.5133 + *
1.5134 + * Internal functions for variable name object types --
1.5135 + *
1.5136 + *----------------------------------------------------------------------
1.5137 + */
1.5138 +
1.5139 +/*
1.5140 + * localVarName -
1.5141 + *
1.5142 + * INTERNALREP DEFINITION:
1.5143 + * twoPtrValue.ptr1 = pointer to the corresponding Proc
1.5144 + * twoPtrValue.ptr2 = index into locals table
1.5145 +*/
1.5146 +
1.5147 +static void
1.5148 +FreeLocalVarName(objPtr)
1.5149 + Tcl_Obj *objPtr;
1.5150 +{
1.5151 + register Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1;
1.5152 + procPtr->refCount--;
1.5153 + if (procPtr->refCount <= 0) {
1.5154 + TclProcCleanupProc(procPtr);
1.5155 + }
1.5156 +}
1.5157 +
1.5158 +static void
1.5159 +DupLocalVarName(srcPtr, dupPtr)
1.5160 + Tcl_Obj *srcPtr;
1.5161 + Tcl_Obj *dupPtr;
1.5162 +{
1.5163 + register Proc *procPtr = (Proc *) srcPtr->internalRep.twoPtrValue.ptr1;
1.5164 +
1.5165 + dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
1.5166 + dupPtr->internalRep.twoPtrValue.ptr2 = srcPtr->internalRep.twoPtrValue.ptr2;
1.5167 + procPtr->refCount++;
1.5168 + dupPtr->typePtr = &tclLocalVarNameType;
1.5169 +}
1.5170 +
1.5171 +static void
1.5172 +UpdateLocalVarName(objPtr)
1.5173 + Tcl_Obj *objPtr;
1.5174 +{
1.5175 + Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1;
1.5176 + unsigned int index = (unsigned int) objPtr->internalRep.twoPtrValue.ptr2;
1.5177 + CompiledLocal *localPtr = procPtr->firstLocalPtr;
1.5178 + unsigned int nameLen;
1.5179 +
1.5180 + if (localPtr == NULL) {
1.5181 + goto emptyName;
1.5182 + }
1.5183 + while (index--) {
1.5184 + localPtr = localPtr->nextPtr;
1.5185 + if (localPtr == NULL) {
1.5186 + goto emptyName;
1.5187 + }
1.5188 + }
1.5189 +
1.5190 + nameLen = (unsigned int) localPtr->nameLength;
1.5191 + objPtr->bytes = ckalloc(nameLen + 1);
1.5192 + memcpy(objPtr->bytes, localPtr->name, nameLen + 1);
1.5193 + objPtr->length = nameLen;
1.5194 + return;
1.5195 +
1.5196 + emptyName:
1.5197 + objPtr->bytes = ckalloc(1);
1.5198 + *(objPtr->bytes) = '\0';
1.5199 + objPtr->length = 0;
1.5200 +}
1.5201 +
1.5202 +/*
1.5203 + * nsVarName -
1.5204 + *
1.5205 + * INTERNALREP DEFINITION:
1.5206 + * twoPtrValue.ptr1: pointer to the namespace containing the
1.5207 + * reference.
1.5208 + * twoPtrValue.ptr2: pointer to the corresponding Var
1.5209 +*/
1.5210 +
1.5211 +static void
1.5212 +FreeNsVarName(objPtr)
1.5213 + Tcl_Obj *objPtr;
1.5214 +{
1.5215 + register Var *varPtr = (Var *) objPtr->internalRep.twoPtrValue.ptr2;
1.5216 +
1.5217 + varPtr->refCount--;
1.5218 + if (TclIsVarUndefined(varPtr) && (varPtr->refCount <= 0)) {
1.5219 + if (TclIsVarLink(varPtr)) {
1.5220 + Var *linkPtr = varPtr->value.linkPtr;
1.5221 + linkPtr->refCount--;
1.5222 + if (TclIsVarUndefined(linkPtr) && (linkPtr->refCount <= 0)) {
1.5223 + CleanupVar(linkPtr, (Var *) NULL);
1.5224 + }
1.5225 + }
1.5226 + CleanupVar(varPtr, NULL);
1.5227 + }
1.5228 +}
1.5229 +
1.5230 +static void
1.5231 +DupNsVarName(srcPtr, dupPtr)
1.5232 + Tcl_Obj *srcPtr;
1.5233 + Tcl_Obj *dupPtr;
1.5234 +{
1.5235 + Namespace *nsPtr = (Namespace *) srcPtr->internalRep.twoPtrValue.ptr1;
1.5236 + register Var *varPtr = (Var *) srcPtr->internalRep.twoPtrValue.ptr2;
1.5237 +
1.5238 + dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr;
1.5239 + dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
1.5240 + varPtr->refCount++;
1.5241 + dupPtr->typePtr = &tclNsVarNameType;
1.5242 +}
1.5243 +
1.5244 +/*
1.5245 + * parsedVarName -
1.5246 + *
1.5247 + * INTERNALREP DEFINITION:
1.5248 + * twoPtrValue.ptr1 = pointer to the array name Tcl_Obj
1.5249 + * (NULL if scalar)
1.5250 + * twoPtrValue.ptr2 = pointer to the element name string
1.5251 + * (owned by this Tcl_Obj), or NULL if
1.5252 + * it is a scalar variable
1.5253 + */
1.5254 +
1.5255 +static void
1.5256 +FreeParsedVarName(objPtr)
1.5257 + Tcl_Obj *objPtr;
1.5258 +{
1.5259 + register Tcl_Obj *arrayPtr =
1.5260 + (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1;
1.5261 + register char *elem = (char *) objPtr->internalRep.twoPtrValue.ptr2;
1.5262 +
1.5263 + if (arrayPtr != NULL) {
1.5264 + TclDecrRefCount(arrayPtr);
1.5265 + ckfree(elem);
1.5266 + }
1.5267 +}
1.5268 +
1.5269 +static void
1.5270 +DupParsedVarName(srcPtr, dupPtr)
1.5271 + Tcl_Obj *srcPtr;
1.5272 + Tcl_Obj *dupPtr;
1.5273 +{
1.5274 + register Tcl_Obj *arrayPtr =
1.5275 + (Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr1;
1.5276 + register char *elem = (char *) srcPtr->internalRep.twoPtrValue.ptr2;
1.5277 + char *elemCopy;
1.5278 + unsigned int elemLen;
1.5279 +
1.5280 + if (arrayPtr != NULL) {
1.5281 + Tcl_IncrRefCount(arrayPtr);
1.5282 + elemLen = strlen(elem);
1.5283 + elemCopy = ckalloc(elemLen+1);
1.5284 + memcpy(elemCopy, elem, elemLen);
1.5285 + *(elemCopy + elemLen) = '\0';
1.5286 + elem = elemCopy;
1.5287 + }
1.5288 +
1.5289 + dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) arrayPtr;
1.5290 + dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) elem;
1.5291 + dupPtr->typePtr = &tclParsedVarNameType;
1.5292 +}
1.5293 +
1.5294 +static void
1.5295 +UpdateParsedVarName(objPtr)
1.5296 + Tcl_Obj *objPtr;
1.5297 +{
1.5298 + Tcl_Obj *arrayPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1;
1.5299 + char *part2 = (char *) objPtr->internalRep.twoPtrValue.ptr2;
1.5300 + char *part1, *p;
1.5301 + int len1, len2, totalLen;
1.5302 +
1.5303 + if (arrayPtr == NULL) {
1.5304 + /*
1.5305 + * This is a parsed scalar name: what is it
1.5306 + * doing here?
1.5307 + */
1.5308 + panic("ERROR: scalar parsedVarName without a string rep.\n");
1.5309 + }
1.5310 + part1 = Tcl_GetStringFromObj(arrayPtr, &len1);
1.5311 + len2 = strlen(part2);
1.5312 +
1.5313 + totalLen = len1 + len2 + 2;
1.5314 + p = ckalloc((unsigned int) totalLen + 1);
1.5315 + objPtr->bytes = p;
1.5316 + objPtr->length = totalLen;
1.5317 +
1.5318 + memcpy(p, part1, (unsigned int) len1);
1.5319 + p += len1;
1.5320 + *p++ = '(';
1.5321 + memcpy(p, part2, (unsigned int) len2);
1.5322 + p += len2;
1.5323 + *p++ = ')';
1.5324 + *p = '\0';
1.5325 +}