ADDED doc/ArraySet.3 Index: doc/ArraySet.3 ================================================================== --- /dev/null +++ doc/ArraySet.3 @@ -0,0 +1,333 @@ +'\" +'\" Copyright (c) 2016 Andy Goth +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH Tcl_ArraySet 3 8.7 Tcl "Tcl Library Procedures" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_ArraySet, Tcl_ArrayUnset, Tcl_ArrayGet, Tcl_ArrayNames, Tcl_ArraySize, Tcl_ArrayExists, Tcl_ArraySearchStart, Tcl_ArraySearchPeek, Tcl_ArraySearchNext, Tcl_ArraySearchDone, Tcl_ArrayStatistics \- manipulate Tcl array variables +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\fBTcl_ArraySet\fR(\fIinterp, part1Ptr, dictPtr, flags\fR) +.sp +int +\fBTcl_ArrayUnset\fR(\fIinterp, part1Ptr, part2Ptr, flags\fR) +.sp +int +\fBTcl_ArrayGet\fR(\fIinterp, part1Ptr, part2Ptr, dictPtr, flags\fR) +.sp +int +\fBTcl_ArrayNames\fR(\fIinterp, part1Ptr, part2Ptr, listPtr, flags\fR) +.sp +int +\fBTcl_ArraySize\fR(\fIinterp, part1Ptr, part2Ptr, intPtr, flags\fR) +.sp +int +\fBTcl_ArrayExists\fR(\fIinterp, part1Ptr, part2ptr, intPtr, flags\fR) +.sp +Tcl_ArraySearch +\fBTcl_ArraySearchStart\fR(\fIinterp, part1Ptr, part2Ptr, flags\fR) +.sp +Tcl_Obj * +\fBTcl_ArraySearchPeek\fR(\fIsearch\fR) +.sp +Tcl_Obj * +\fBTcl_ArraySearchNext\fR(\fIsearch\fR) +.sp +void +\fBTcl_ArraySearchDone\fR(\fIsearch\fR) +.sp +int +\fBTcl_ArrayStatistics\fR(\fIinterp, part1Ptr, stringPtr, flags\fR) +.SH ARGUMENTS +.AS Tcl_ArraySearch search +.AP Tcl_Interp *interp in +Interpreter containing the variable. If an error occurs, an error message is +left in the interpreter's result. +.AP Tcl_Obj *part1Ptr in +Points to a Tcl value containing the array variable's name. The name may +include a series of \fB::\fR namespace qualifiers to specify a variable in a +particular namespace. +.AP Tcl_Obj *part2Ptr in +If non-NULL, points to a Tcl value containing an array element name filter +specification. The format and interpretation of \fIpart2Ptr\fR are determined +by the \fIflags\fR argument. +.AP int flags in +OR-ed combination of bits providing additional information. See below for valid +values. +.AP Tcl_Obj *dictPtr in/out +Points to the dictionary value to be read or manipulated. If \fIdictPtr\fR does +not already point to a dictionary value, an attempt will be made to convert it +to one. \fBTcl_ArraySet\fR allows \fIdictPtr\fR to be NULL, in which case it +creates an empty array if the array does not already exist. +.AP Tcl_Obj *listPtr in/out +Points to the list value to be manipulated. If \fIlistPtr\fR does not already +point to a list value, an attempt will be made to convert it to one. +.AP Tcl_Obj *stringPtr in/out +Points to the string value to be manipulated. +.AP int *intPtr out +Points to location where \fBTcl_ArrayExists\fR stores the array existence flag +or \fBTcl_ArraySize\fR stores the number of matching array elements. +.AP Tcl_ArraySearch search in/out +Token for tracking the progress of enumerating array elements. +.BE +.SH DESCRIPTION +.PP +These functions are used to create, modify, enumerate, analyze, read, and delete +Tcl array variables from C code. +.PP +The \fBTcl_ArraySet\fR, \fBTcl_ArrayUnset\fR, \fBTcl_ArrayGet\fR, +\fBTcl_ArrayNames\fR, \fBTcl_ArraySize\fR, \fBTcl_ArrayExists\fR, and +\fBTcl_ArrayStatistics\fR functions return \fBTCL_OK\fR on success and +\fBTCL_ERROR\fR on error. If an error occurs, an error message is left in the +interpreter's result. The possible errors are caused by format (invalid list, +dictionary, or regular expression) and traces (array, read, write, or unset). +.PP +Except for \fBTcl_ArraySet\fR, \fBTcl_ArraySearchStart\fR (not listed above), +and \fBTcl_ArrayStatistics\fR, the array functions do not consider it an error +for a namespace or variable to not exist or a variable to be a scalar or array +element instead of an array. \fBTcl_ArraySet\fR allows the array variable to +not exist, in which case it creates it, but it returns \fBTCL_ERROR\fR in all +the other situations listed in the previous sentence. +.PP +Array functions trigger array traces in the same manner as the \fBarray\fR +command. After the completion of any array traces, for each accessed array +element, \fBTcl_ArraySet\fR triggers write traces, \fBTcl_ArrayUnset\fR triggers +unset traces, and \fBTcl_ArrayGet\fR triggers read traces. As discussed above, +an error encountered during the execution of a trace causes the function to +place error information in the interpreter's result and return \fBTCL_ERROR\fR. +.PP +The \fBTcl_ArraySet\fR, \fBTcl_ArrayUnset\fR, \fBTcl_ArrayGet\fR, +\fBTcl_ArrayNames\fR, \fBTcl_ArraySize\fR, \fBTcl_ArrayExists\fR, +\fBTcl_ArraySearchStart\fR, and \fBTcl_ArrayStatistics\fR functions accept a +\fIflags\fR argument to control the scope of the variable lookup and to specify +the interpretation of \fIpart2Ptr\fR. It consists of an OR-ed combination of +zero or more of the following bits. +.TP +\fBTCL_GLOBAL_ONLY\fR +Under normal circumstances the functions look up variables as follows. If a +procedure call is active in \fIinterp\fR, the array variable is looked up at the +current level of procedure call. Otherwise, the array variable is looked up +first in the current namespace, then in the global namespace. However, if this +bit is set in \fIflags\fR then the array variable is looked up only in the +global namespace even if there is a procedure call active. If both +\fBTCL_GLOBAL_ONLY\fR and \fBTCL_NAMESPACE_ONLY\fR are given, +\fBTCL_GLOBAL_ONLY\fR is ignored. +.TP +\fBTCL_NAMESPACE_ONLY\fR +If this bit is set in \fIflags\fR then the array variable is looked up only in +the current namespace. If a procedure is active, its variables are ignored, and +the global namespace is also ignored unless it is the current namespace. +.PP +With the exception of \fBTcl_ArraySet\fR and \fBTcl_ArrayStatistics\fR which do +not support filtering, the \fIflags\fR argument is also OR-ed with zero or one +of the following values to select the type of filtering applied by +\fIpart2Ptr\fR. Setting more than one filter type may cause \fBTcl_Panic\fR to +be called. The filter type is ignored if \fIpart2Ptr\fR is NULL, in which case +no filtering is applied and all array elements are matched. +.TP +\fBTCL_MATCH_EXACT\fR +\fIpart2Ptr\fR is an array element name. The filter matches at most a single +array element whose name is exactly equal to the value of \fIpart2Ptr\fR. If no +filter type is explicitly specified in \fIflags\fR, \fBTCL_MATCH_EXACT\fR is +used by default. This differs from the \fBarray\fR commands which default to +\fB\-glob\fR. +.TP +\fBTCL_MATCH_GLOB\fR +\fIpart2Ptr\fR is a glob pattern, and it matches array element names according +to the rules of \fBstring match\fR. \fIpart2Ptr\fR must match the entire array +element name from beginning to end. To match substrings, place \fB*\fR at +either end of \fIpart2Ptr\fR. +.TP +\fBTCL_MATCH_REGEXP\fR +\fIpart2Ptr\fR is a regular expression, and it matches array element names +according to the rules of \fBregexp\fR. Unless anchored by the \fB^\fR and +\fB$\fR constraints, \fIpart2Ptr\fR matches substrings. Thus, an empty +\fIpart2Ptr\fR matches every possible array element name. It is an error for +\fIpart2Ptr\fR to not be a valid regular expression, but this error is only +detected and reported when \fIpart1Ptr\fR names a non-empty array. +.PP +The \fBTcl_ArraySet\fR, \fBTcl_ArrayGet\fR, and \fBTcl_ArrayNames\fR functions +accept \fIdictPtr\fR and \fIlistPtr\fR arguments referencing dictionary and list +values, respectively. If these values are not already dictionary and list +values, an attempt will be made to convert them. If the conversion fails, +\fBTCL_ERROR\fR will be returned and an error message will be left in the +interpreter's result. +.PP +\fBTcl_ArraySet\fR sets the values of zero or more elements in the array named +by \fIpart1Ptr\fR. If not NULL, \fIdictPtr\fR must be a valid dictionary, i.e. +it must be a list consisting of an even number of elements alternating between +key and value. Each key in \fIdictPtr\fR is treated as an element name within +the array, and its associated value is used as the new value for that array +element. If the variable named by \fIpart1Ptr\fR does not already exist and +\fIdictPtr\fR is empty or NULL, the variable is created as an empty array. It +is an error for \fIpart1Ptr\fR to name a scalar (non-array) variable or an array +element, or for it to reference a nonexistent namespace. +.PP +\fBTcl_ArrayUnset\fR unsets all elements in the array named by \fIpart1Ptr\fR +that match the filter specified by \fIpart2Ptr\fR and \fIflags\fR. It is not an +error for \fIpart1Ptr\fR to not name an array or for there to be no matching +elements in the array. If \fIpart2Ptr\fR is NULL and \fIpart1Ptr\fR names an +array, the entire array is unset, and future calls to \fBTcl_ArrayExists\fR will +report it as not existing. This is distinct from unsetting each element of the +array (e.g. if \fIpart2Ptr\fR is \fB*\fR and \fIflags\fR is +\fBTCL_MATCH_GLOB\fR), which does not cause future calls to +\fBTcl_ArrayExists\fR to report the array as not existing. +.PP +\fBTcl_ArrayGet\fR loads the contents of the array named by \fIpart1Ptr\fR into +the \fIdictPtr\fR dictionary object. The array element names and values are +used as the dictionary keys and values, respectively. If \fIpart2Ptr\fR is not +NULL, \fIpart2Ptr\fR and \fIflags\fR specify a filter used to limit which array +elements are loaded into \fIdictPtr\fR. If \fIpart1Ptr\fR does not name an +array or if there are no matching elements, \fIdictPtr\fR is not modified. +If \fIdictPtr\fR is not empty prior to calling \fBTcl_ArrayGet\fR, the array +data is merged into \fIdictPtr\fR. If an array element has the same name as an +existing dictionary key, the array element value replaces the existing +dictionary value. +.PP +\fBTcl_ArrayNames\fR loads the element names of the array named by +\fIpart1Ptr\fR into the \fIlistPtr\fR list object. If \fIpart2Ptr\fR is not +NULL, \fIpart2Ptr\fR and \fIflags\fR specify a filter used to limit which array +element names are loaded into \fIlistPtr\fR. If \fIpart1Ptr\fR does not name an +array or if there are no matching elements, \fIlistPtr\fR is not modified. If +\fIlistPtr\fR is not empty prior to calling \fBTcl_ArrayNames\fR, the array +element names are appended to \fIlistPtr\fR. +.PP +\fBTcl_ArraySize\fR stores the number of elements in the array named by +\fIpart1Ptr\fR into the address \fIintPtr\fR. If \fIpart2Ptr\fR is not NULL, +\fIpart2Ptr\fR and \fIflags\fR specify a filter used to limit which array +elements count toward the total number of elements. +.PP +\fBTcl_ArrayExists\fR checks for the existence of an array variable named +\fIpart1Ptr\fR or (if \fIpart2Ptr\fR is not NULL) an array element within +matching the filter specified by \fIpart2Ptr\fR and \fIflags\fR. If the array +variable or array element exists, the value \fB1\fR is stored into the location +\fIintPtr\fR, even if the array is empty. If \fIpart1Ptr\fR does not name an +array variable (the variable does not exist, it is a scalar variable or array +element, or it references a nonexistent namespace), or if \fIpart2Ptr\fR is not +NULL and no elements match the filter, the value \fB0\fR is stored into the +location \fIintPtr\fR. +.PP +\fBTcl_ArraySearchStart\fR initiates an array search, i.e. an array element +enumeration yielding one element at a time. \fIpart1Ptr\fR must name an array. +If \fIpart2Ptr\fR is not NULL, \fIpart2Ptr\fR and \fIflags\fR specify a filter +used to limit which array elements are included in the enumeration. The return +value is a token used to track the progress of the search, and it is to be +passed to the \fBTcl_ArraySearchPeek\fR, \fBTcl_ArraySearchNext\fR, and +\fBTcl_ArraySearchDone\fR functions. If there is an error looking up the +variable, executing an array trace, or validating a regular expression filter, +NULL is returned and error information is placed in the interpreter result. +.PP +\fBTcl_ArraySearchPeek\fR and \fBTcl_ArraySearchNext\fR return the next array +element name in the search identified by the \fIsearch\fR argument. If there +are no remaining element names, NULL is returned. \fBTcl_ArraySearchPeek\fR +does not advance the enumeration, whereas \fBTcl_ArraySearchNext\fR does, so +\fBTcl_ArraySearchPeek\fR will return the same value each time it is called if +there are no intervening calls to \fBTcl_ArraySearchNext\fR with the same +\fIsearch\fR argument. +.PP +\fBTcl_ArraySearchDone\fR completes the search identified by the \fIsearch\fR +argument and deallocates associated resources. To avoid memory leaks, +\fBTcl_ArraySearchDone\fR must be called once for each search token returned by +\fBTcl_ArraySearchStart\fR. +.PP +\fBTcl_ArrayStatistics\fR produces statistics about the distribution of data +within the hash table underlying the array named by \fIpart1Ptr\fR. This +information includes the number of entries in the table, the number of buckets, +and the utilization of the buckets. The statistics information is appended to +the string value \fIstringPtr\fR. +.SH EXAMPLES +.PP +Common initialization used for subsequent examples: +.PP +.CS +int size, i; +Tcl_Obj *obj, **objPtr; +Tcl_Obj *varNameObj = Tcl_NewStringObj("colorcount", -1); +Tcl_Channel outChan = Tcl_GetChannel(interp, "stdout", NULL); +.CE +.PP +Create an array: +.PP +.CS +obj = Tcl_NewStringObj( + " red 1" + " green 5" + " blue 4" + " white 9", -1); +\fBTcl_ArraySet\fR(interp, varNameObj, obj, 0); +.CE +.PP +Load the full contents of an array into a single object: +.PP +.CS +Tcl_SetStringObj(obj, NULL, 0); +\fBTcl_ArrayGet\fR(interp, varNameObj, NULL, obj, 0); +Tcl_ListObjGetElements(interp, obj, &size, &objPtr); +for (i = 0; i < size; i += 2, objPtr += 2) { + Tcl_WriteChars(outChan, "Color: ", -1); + Tcl_WriteObj(outChan, objPtr[0]); + Tcl_WriteChars(outChan, " Count: ", -1); + Tcl_WriteObj(outChan, objPtr[1]); + Tcl_WriteChars(outChan, "\\n", -1); +} + \fB\(->\fR Color: blue Count: 4 + Color: white Count: 9 + Color: green Count: 5 + Color: red Count: 1 +.CE +.PP +Get an array element name list then individually look up each element value: +.PP +.CS +Tcl_SetStringObj(obj, NULL, 0); +\fBTcl_ArrayNames\fR(interp, varNameObj, NULL, obj, 0); +Tcl_ListObjGetElements(interp, obj, &size, &objPtr); +for (i = 0; i < size; ++i, ++objPtr) { + Tcl_WriteChars(outChan, "Color: ", -1); + Tcl_WriteObj(outChan, *objPtr); + Tcl_WriteChars(outChan, " Count: ", -1); + Tcl_WriteObj(outChan, Tcl_ObjGetVar2( + interp, varNameObj, *objPtr, 0)); + Tcl_WriteChars(outChan, "\\n", -1); +} + \fB\(->\fR Color: blue Count: 4 + Color: white Count: 9 + Color: green Count: 5 + Color: red Count: 1 +.CE +.PP +Get array hash table statistics: +.PP +.CS +Tcl_SetStringObj(obj, NULL, 0); +\fBTcl_ArrayStatistics\fR(interp, varNameObj, obj, 0); +Tcl_WriteObj(outChan, obj); +Tcl_WriteChars(outChan, "\\n", -1); + \fB\(->\fR 4 entries in table, 4 buckets + number of buckets with 0 entries: 1 + number of buckets with 1 entries: 2 + number of buckets with 2 entries: 1 + number of buckets with 3 entries: 0 + number of buckets with 4 entries: 0 + number of buckets with 5 entries: 0 + number of buckets with 6 entries: 0 + number of buckets with 7 entries: 0 + number of buckets with 8 entries: 0 + number of buckets with 9 entries: 0 + number of buckets with 10 or more entries: 0 + average search distance for entry: 1.2 +.CE +.SH "SEE ALSO" +array(n), Tcl_NewObj(3), Tcl_NewListObj(3), Tcl_NewDictObj(3), +Tcl_ObjGetVar2(3), Tcl_GetObjResult(3), Tcl_TraceVar2(3) +.SH KEYWORDS +array, dict, dict value, dictionary, get variable, hash table, iteration, +interpreter, set, unset, value, variable Index: doc/array.n ================================================================== --- doc/array.n +++ doc/array.n @@ -20,10 +20,46 @@ variable given by \fIarrayName\fR. Unless otherwise specified for individual commands below, \fIarrayName\fR must be the name of an existing array variable. The \fIoption\fR argument determines what action is carried out by the command. +.PP +Many array commands accept \fImode\fR and \fIpattern\fR arguments. These +arguments specify a filter to limit which array elements are included in the +operation. If neither argument is specified, no filtering is applied, and the +entire array is processed. If only one argument is specified, it is used as the +\fIpattern\fR argument, and \fB\-glob\fR is used as the default value for +\fImode\fR. If both arguments are specified, the first is used as \fImode\fR +and the second as \fIpattern\fR. The \fImode\fR argument designates which +matching rules to use to match \fIpattern\fR against the names of the elements +in the array. The legal \fImode\fR values are: +.TP +\fB\-exact\fR +. +\fIPattern\fR is a literal string that is compared for exact equality against +each array element name. This mode has limited utility because all uses of the +\fBarray\fR command with \fB-exact\fR matching can be implemented by operating +directly on the array element with standard \fIname\fB(\fIindex\fB)\fR notation. +.TP +\fB\-glob\fR +. +\fIPattern\fR is a glob-style pattern which is matched against each array +element name using the same rules as the \fBstring match\fR command. +\fIPattern\fR must match the entire array element name from beginning to end. +To match substrings, place \fB*\fR at either end of \fIpattern\fR. This mode is +the default if no \fImode\fR is specified. +.TP +\fB\-regexp\fR +. +\fIPattern\fR is treated as a regular expression and matched against each array +element name using the rules described in the \fBre_syntax\fR reference page. +Unless anchored by the \fB^\fR and \fB$\fR constraints, \fIpattern\fR matches +substrings. Thus, an empty \fIpattern\fR matches every possible array element +name. It is an error for \fIpattern\fR to not be a valid regular expression, +but this error condition is only detected and reported when \fIarrayName\fR is a +non-empty array. +.PP The legal \fIoptions\fR (which may be abbreviated) are: .TP \fBarray anymore \fIarrayName searchId\fR Returns 1 if there are any more elements left to be processed in an array search, 0 if all elements have already been @@ -41,41 +77,36 @@ state associated with that search. \fISearchId\fR indicates which search on \fIarrayName\fR to destroy, and must have been the return value from a previous invocation of \fBarray startsearch\fR. Returns an empty string. .TP -\fBarray exists \fIarrayName\fR +\fBarray exists \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR? Returns 1 if \fIarrayName\fR is an array variable, 0 if there is no variable by that name or if it is a scalar variable. +If \fIpattern\fR is specified, this command instead checks if one or more +elements of \fIarrayName\fR match the filter defined by \fImode\fR and +\fIpattern\fR, returning 1 or 0 if the match succeeds or fails, respectively. .TP -\fBarray get \fIarrayName\fR ?\fIpattern\fR? +\fBarray get \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR? Returns a list containing pairs of elements. The first element in each pair is the name of an element in \fIarrayName\fR and the second element of each pair is the value of the array element. The order of the pairs is undefined. -If \fIpattern\fR is not specified, then all of the elements of the -array are included in the result. -If \fIpattern\fR is specified, then only those elements whose names -match \fIpattern\fR (using the matching rules of -\fBstring match\fR) are included. +The \fImode\fR and \fIpattern\fR arguments can be used to limit which array +elements are included in the result. If \fIarrayName\fR is not the name of an array variable, or if the array contains no elements, then an empty list is returned. If traces on the array modify the list of elements, the elements returned are those that exist both before and after the call to \fBarray get\fR. .TP \fBarray names \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR? Returns a list containing the names of all of the elements in -the array that match \fIpattern\fR. \fIMode\fR may be one of -\fB\-exact\fR, \fB\-glob\fR, or \fB\-regexp\fR. If specified, \fImode\fR -designates which matching rules to use to match \fIpattern\fR against -the names of the elements in the array. If not specified, \fImode\fR -defaults to \fB\-glob\fR. See the documentation for \fBstring match\fR -for information on glob style matching, and the documentation for -\fBregexp\fR for information on regexp matching. -If \fIpattern\fR is omitted then the command returns all of -the element names in the array. If there are no (matching) elements +the array. +The \fImode\fR and \fIpattern\fR arguments can be used to limit which array +element names are included in the result. +If there are no (matching) elements in the array, or if \fIarrayName\fR is not the name of an array variable, then an empty string is returned. .TP \fBarray nextelement \fIarrayName searchId\fR Returns the name of the next element in \fIarrayName\fR, or @@ -97,20 +128,24 @@ is used as a new value for that array element. If the variable \fIarrayName\fR does not already exist and \fIlist\fR is empty, \fIarrayName\fR is created with an empty array value. .TP -\fBarray size \fIarrayName\fR -Returns a decimal string giving the number of elements in the +\fBarray size \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR? +Returns an integer giving the number of elements in the array. +The \fImode\fR and \fIpattern\fR arguments can be used to limit which array +elements are counted toward the result. If \fIarrayName\fR is not the name of an array then 0 is returned. .TP -\fBarray startsearch \fIarrayName\fR +\fBarray startsearch \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR? This command initializes an element-by-element search through the array given by \fIarrayName\fR, such that invocations of the \fBarray nextelement\fR command will return the names of the individual elements in the array. +The \fImode\fR and \fIpattern\fR arguments can be used to limit which array +element names are returned by future invocations of \fBarray nextelement\fR. When the search has been completed, the \fBarray donesearch\fR command should be invoked. The return value is a search identifier that must be used in \fBarray nextelement\fR and \fBarray donesearch\fR commands; it allows multiple @@ -124,13 +159,14 @@ Returns statistics about the distribution of data within the hashtable that represents the array. This information includes the number of entries in the table, the number of buckets, and the utilization of the buckets. .TP -\fBarray unset \fIarrayName\fR ?\fIpattern\fR? -Unsets all of the elements in the array that match \fIpattern\fR (using the -matching rules of \fBstring match\fR). If \fIarrayName\fR is not the name +\fBarray unset \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR? +Unsets all of the elements in the array that match the filter specified by the +\fImode\fR and \fIpattern\fR arguments. +If \fIarrayName\fR is not the name of an array variable or there are no matching elements in the array, no error will be raised. If \fIpattern\fR is omitted and \fIarrayName\fR is an array variable, then the command unsets the entire array. The command always returns an empty string. .SH EXAMPLES Index: generic/tcl.decls ================================================================== --- generic/tcl.decls +++ generic/tcl.decls @@ -2323,10 +2323,55 @@ void Tcl_ZlibStreamSetCompressionDictionary(Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj) } # ----- BASELINE -- FOR -- 8.6.0 ----- # + +# TIP #XXX +declare 631 { + int Tcl_ArraySet(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *dictPtr, + int flags) +} +declare 632 { + int Tcl_ArrayUnset(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + int flags) +} +declare 633 { + int Tcl_ArrayGet(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + Tcl_Obj *dictPtr, int flags) +} +declare 634 { + int Tcl_ArrayNames(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + Tcl_Obj *listPtr, int flags) +} +declare 635 { + int Tcl_ArraySize(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + int *intPtr, int flags) +} +declare 636 { + int Tcl_ArrayExists(Tcl_Interp *interp, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, int *intPtr, int flags) +} +declare 637 { + Tcl_ArraySearch Tcl_ArraySearchStart(Tcl_Interp *interp, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags) +} +declare 638 { + int Tcl_ArraySearchPeek(Tcl_Interp *interp, Tcl_ArraySearch search, + Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr) +} +declare 639 { + int Tcl_ArraySearchNext(Tcl_Interp *interp, Tcl_ArraySearch search, + Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr) +} +declare 640 { + int Tcl_ArraySearchDone(Tcl_Interp *interp, Tcl_ArraySearch search) +} +declare 641 { + int Tcl_ArrayStatistics(Tcl_Interp *interp, Tcl_Obj *part1Ptr, + Tcl_Obj *stringPtr, int flags) +} ############################################################################## # Define the platform specific public Tcl interface. These functions are only # available on the designated platform. Index: generic/tcl.h ================================================================== --- generic/tcl.h +++ generic/tcl.h @@ -530,10 +530,11 @@ #endif } #endif /* TCL_NO_DEPRECATED */ Tcl_Interp; +typedef struct Tcl_ArraySearch_ *Tcl_ArraySearch; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; typedef struct Tcl_Command_ *Tcl_Command; typedef struct Tcl_Condition_ *Tcl_Condition; @@ -1081,13 +1082,14 @@ #define TCL_DYNAMIC ((Tcl_FreeProc *) 3) /* * Flag values passed to variable-related functions. * WARNING: these bit choices must not conflict with the bit choice for - * TCL_CANCEL_UNWIND, above. + * TCL_CANCEL_UNWIND, above, or TCL_VAR_CREATE (0x4000) in tclVar.c. */ +#define TCL_MATCH_EXACT 0 #define TCL_GLOBAL_ONLY 1 #define TCL_NAMESPACE_ONLY 2 #define TCL_APPEND_VALUE 4 #define TCL_LIST_ELEMENT 8 #define TCL_TRACE_READS 0x10 @@ -1094,18 +1096,23 @@ #define TCL_TRACE_WRITES 0x20 #define TCL_TRACE_UNSETS 0x40 #define TCL_TRACE_DESTROYED 0x80 #define TCL_INTERP_DESTROYED 0x100 #define TCL_LEAVE_ERR_MSG 0x200 +/* Value 0x400 is reserved for TCL_PARSE_PART1, conditionally defined below. */ #define TCL_TRACE_ARRAY 0x800 #ifndef TCL_REMOVE_OBSOLETE_TRACES /* Required to support old variable/vdelete/vinfo traces. */ #define TCL_TRACE_OLD_STYLE 0x1000 #endif +#define TCL_MATCH_REGEXP 0x2000 +/* Value 0x4000 is reserved for TCL_VAR_CREATE, defined in tclVar.c. */ /* Indicate the semantics of the result of a trace. */ #define TCL_TRACE_RESULT_DYNAMIC 0x8000 #define TCL_TRACE_RESULT_OBJECT 0x10000 +#define TCL_MATCH_GLOB 0x20000 +/* Value 0x100000 is reserved for TCL_CANCEL_UNWIND, defined above. */ /* * Flag values for ensemble commands. */ Index: generic/tclDecls.h ================================================================== --- generic/tclDecls.h +++ generic/tclDecls.h @@ -1814,10 +1814,50 @@ Tcl_LoadHandle handlePtr); /* 630 */ EXTERN void Tcl_ZlibStreamSetCompressionDictionary( Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); +/* 631 */ +EXTERN int Tcl_ArraySet(Tcl_Interp *interp, Tcl_Obj *part1Ptr, + Tcl_Obj *dictPtr, int flags); +/* 632 */ +EXTERN int Tcl_ArrayUnset(Tcl_Interp *interp, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, int flags); +/* 633 */ +EXTERN int Tcl_ArrayGet(Tcl_Interp *interp, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, Tcl_Obj *dictPtr, + int flags); +/* 634 */ +EXTERN int Tcl_ArrayNames(Tcl_Interp *interp, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, Tcl_Obj *listPtr, + int flags); +/* 635 */ +EXTERN int Tcl_ArraySize(Tcl_Interp *interp, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, int *intPtr, int flags); +/* 636 */ +EXTERN int Tcl_ArrayExists(Tcl_Interp *interp, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + int *intPtr, int flags); +/* 637 */ +EXTERN Tcl_ArraySearch Tcl_ArraySearchStart(Tcl_Interp *interp, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + int flags); +/* 638 */ +EXTERN int Tcl_ArraySearchPeek(Tcl_Interp *interp, + Tcl_ArraySearch search, Tcl_Obj **keyPtrPtr, + Tcl_Obj **valuePtrPtr); +/* 639 */ +EXTERN int Tcl_ArraySearchNext(Tcl_Interp *interp, + Tcl_ArraySearch search, Tcl_Obj **keyPtrPtr, + Tcl_Obj **valuePtrPtr); +/* 640 */ +EXTERN int Tcl_ArraySearchDone(Tcl_Interp *interp, + Tcl_ArraySearch search); +/* 641 */ +EXTERN int Tcl_ArrayStatistics(Tcl_Interp *interp, + Tcl_Obj *part1Ptr, Tcl_Obj *stringPtr, + int flags); typedef struct { const struct TclPlatStubs *tclPlatStubs; const struct TclIntStubs *tclIntStubs; const struct TclIntPlatStubs *tclIntPlatStubs; @@ -2480,10 +2520,21 @@ int (*tcl_NRSubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 626 */ int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */ void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ + int (*tcl_ArraySet) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *dictPtr, int flags); /* 631 */ + int (*tcl_ArrayUnset) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 632 */ + int (*tcl_ArrayGet) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *dictPtr, int flags); /* 633 */ + int (*tcl_ArrayNames) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *listPtr, int flags); /* 634 */ + int (*tcl_ArraySize) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int *intPtr, int flags); /* 635 */ + int (*tcl_ArrayExists) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int *intPtr, int flags); /* 636 */ + Tcl_ArraySearch (*tcl_ArraySearchStart) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 637 */ + int (*tcl_ArraySearchPeek) (Tcl_Interp *interp, Tcl_ArraySearch search, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr); /* 638 */ + int (*tcl_ArraySearchNext) (Tcl_Interp *interp, Tcl_ArraySearch search, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr); /* 639 */ + int (*tcl_ArraySearchDone) (Tcl_Interp *interp, Tcl_ArraySearch search); /* 640 */ + int (*tcl_ArrayStatistics) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *stringPtr, int flags); /* 641 */ } TclStubs; extern const TclStubs *tclStubsPtr; #ifdef __cplusplus @@ -3772,10 +3823,32 @@ (tclStubsPtr->tcl_FindSymbol) /* 628 */ #define Tcl_FSUnloadFile \ (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ #define Tcl_ZlibStreamSetCompressionDictionary \ (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ +#define Tcl_ArraySet \ + (tclStubsPtr->tcl_ArraySet) /* 631 */ +#define Tcl_ArrayUnset \ + (tclStubsPtr->tcl_ArrayUnset) /* 632 */ +#define Tcl_ArrayGet \ + (tclStubsPtr->tcl_ArrayGet) /* 633 */ +#define Tcl_ArrayNames \ + (tclStubsPtr->tcl_ArrayNames) /* 634 */ +#define Tcl_ArraySize \ + (tclStubsPtr->tcl_ArraySize) /* 635 */ +#define Tcl_ArrayExists \ + (tclStubsPtr->tcl_ArrayExists) /* 636 */ +#define Tcl_ArraySearchStart \ + (tclStubsPtr->tcl_ArraySearchStart) /* 637 */ +#define Tcl_ArraySearchPeek \ + (tclStubsPtr->tcl_ArraySearchPeek) /* 638 */ +#define Tcl_ArraySearchNext \ + (tclStubsPtr->tcl_ArraySearchNext) /* 639 */ +#define Tcl_ArraySearchDone \ + (tclStubsPtr->tcl_ArraySearchDone) /* 640 */ +#define Tcl_ArrayStatistics \ + (tclStubsPtr->tcl_ArrayStatistics) /* 641 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -4032,16 +4032,17 @@ while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } TRACE(("%s %u \"%.30s\" => ", (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr))); - if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) { + if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr) + && !TclIsVarArraySearched(arrayPtr)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); if (varPtr && TclIsVarDirectUnsettable(varPtr)) { /* - * No nasty traces and element exists, so we can proceed to - * unset it. Might still not exist though... + * No nasty traces or searchesw and element exists, so we can + * proceed to unset it. Might still not exist though... */ if (!TclIsVarUndefined(varPtr)) { TclDecrRefCount(varPtr->value.objPtr); TclSetVarUndefined(varPtr); Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -802,10 +802,11 @@ * MODULE_SCOPE int TclIsVarUndefined(Var *varPtr); * MODULE_SCOPE int TclIsVarArrayElement(Var *varPtr); * MODULE_SCOPE int TclIsVarTemporary(Var *varPtr); * MODULE_SCOPE int TclIsVarArgument(Var *varPtr); * MODULE_SCOPE int TclIsVarResolved(Var *varPtr); + * MODULE_SCOPE int TclIsVarArraySearched(Var *varPtr); */ #define TclIsVarScalar(varPtr) \ !((varPtr)->flags & (VAR_ARRAY|VAR_LINK)) @@ -843,10 +844,13 @@ ((varPtr)->flags & VAR_IN_HASHTABLE) #define TclIsVarDeadHash(varPtr) \ ((varPtr)->flags & VAR_DEAD_HASH) +#define TclIsVarArraySearched(varPtr) \ + ((varPtr)->flags & VAR_SEARCH_ACTIVE) + #define TclGetVarNsPtr(varPtr) \ (TclIsVarInHash(varPtr) \ ? ((TclVarHashTable *) ((((VarInHash *) (varPtr))->entry.tablePtr)))->nsPtr \ : NULL) Index: generic/tclStubInit.c ================================================================== --- generic/tclStubInit.c +++ generic/tclStubInit.c @@ -1414,8 +1414,19 @@ Tcl_NRSubstObj, /* 626 */ Tcl_LoadFile, /* 627 */ Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ + Tcl_ArraySet, /* 631 */ + Tcl_ArrayUnset, /* 632 */ + Tcl_ArrayGet, /* 633 */ + Tcl_ArrayNames, /* 634 */ + Tcl_ArraySize, /* 635 */ + Tcl_ArrayExists, /* 636 */ + Tcl_ArraySearchStart, /* 637 */ + Tcl_ArraySearchPeek, /* 638 */ + Tcl_ArraySearchNext, /* 639 */ + Tcl_ArraySearchDone, /* 640 */ + Tcl_ArrayStatistics, /* 641 */ }; /* !END!: Do not edit above this line. */ Index: generic/tclVar.c ================================================================== --- generic/tclVar.c +++ generic/tclVar.c @@ -40,19 +40,32 @@ static inline Var * VarHashCreateVar(TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr); static inline Var * VarHashFirstVar(TclVarHashTable *tablePtr, Tcl_HashSearch *searchPtr); static inline Var * VarHashNextVar(Tcl_HashSearch *searchPtr); -static inline void CleanupVar(Var *varPtr, Var *arrayPtr); #define VarHashGetValue(hPtr) \ ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) /* - * NOTE: VarHashCreateVar increments the recount of its key argument. + * Bit mask matching any of the bits used to select a match filter. AND this + * mask against a flags value to obtain a value which can be compared against + * each of the available match modes using the "==" equality operator. + */ + +#define TCL_MATCH (TCL_MATCH_EXACT | TCL_MATCH_GLOB | TCL_MATCH_REGEXP) + +/* + * ArrayVar()-specific flag to enable array variable creation. + */ + +#define TCL_VAR_CREATE 0x4000 + +/* + * NOTE: VarHashCreateVar increments the refcount of its key argument. * All callers that will call Tcl_DecrRefCount on that argument must - * call Tcl_IncrRefCount on it before passing it in. This requirement + * call Tcl_IncrRefCount on it before passing it in. This requirement * can bubble up to callers of callers .... etc. */ static inline Var * VarHashCreateVar( @@ -141,34 +154,70 @@ * true if we are inside a procedure body. */ #define HasLocalVars(framePtr) ((framePtr)->isProcCallFrame & FRAME_IS_PROC) +/* + * Array search flags. + */ + +enum { + KEEP_ON_ABORT_BIT, + SEARCH_ABORTED_BIT, + + /* + * If set, the search structure is not automatically freed when the search + * terminates early due to an array element being added or removed or the + * array itself being deleted. In this case, the search structure is kept + * until the next time a search operation is performed, at which time it is + * deallocated and an error is reported. + */ + + KEEP_ON_ABORT = 1 << KEEP_ON_ABORT_BIT, + + /* + * If KEEP_ON_ABORT is set and the search has terminated early, in lieu of + * immediately freeing the search structure, this bit is set so that it will + * be freed the next time a search operation is performed. + */ + + SEARCH_ABORTED = 1 << SEARCH_ABORTED_BIT, +}; + /* * The following structure describes an enumerative search in progress on an - * array variable; this are invoked with options to the "array" command. + * array variable. It is used by various Tcl_Array*() functions and their + * respective [array] script interface commands. */ -typedef struct ArraySearch { - Tcl_Obj *name; /* Name of this search */ +typedef struct Tcl_ArraySearch_ ArraySearch; +struct Tcl_ArraySearch_ { + Tcl_Obj *name; /* Name of this search. NULL if this search was + * created by Tcl_ArraySearchStart() rather than + * the [array startsearch] command. This is done + * to prevent C-initiated searches from being + * accessed via Tcl commands since they have + * different memory management semantics. */ int id; /* Integer id used to distinguish among * multiple concurrent searches for the same * array. */ - struct Var *varPtr; /* Pointer to array variable that's being + Tcl_Obj *varNameObj; /* Name of the array variable. */ + Var *varPtr; /* Pointer to array variable that's being * searched. */ Tcl_HashSearch search; /* Info kept by the hash module about progress * through the array. */ - Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to - * be enumerated (it's leftover from the - * Tcl_FirstHashEntry call or from an "array - * anymore" command). NULL means must call - * Tcl_NextHashEntry to get value to - * return. */ - struct ArraySearch *nextPtr;/* Next in list of all active searches for + Var *nextEntry; /* Non-NULL means this is the next element to + * be enumerated (left over from ArrayFirst() + * or [array anymore]). NULL means must call + * ArrayNext() to get value to return. */ + ArraySearch *nextPtr; /* Next in list of all active searches for * this variable, or NULL if this is the last * one. */ -} ArraySearch; + Tcl_Obj *filterObj; /* Search filter pattern, or NULL if none. */ + int filterType; /* TCL_MATCH_EXACT, _GLOB, or _REGEXP. */ + int flags; /* Search status flags as defined above. */ +}; /* * Forward references to functions defined later in this file: */ @@ -187,11 +236,28 @@ static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, Tcl_Obj *varNamePtr, Tcl_Obj *handleObj); static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, Interp *iPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, int index); -static Var * VerifyArray(Tcl_Interp *interp, Tcl_Obj *varNameObj); +static Var * ArrayVar(Tcl_Interp *interp, Tcl_Obj *varNameObj, + int *traceFailPtr, int flags); +static int ArrayVarTrace(Tcl_Interp *interp, Var *varPtr, + Tcl_Obj *varNameObj); +static Var * ArrayFirst(Tcl_Interp *interp, ArraySearch *searchPtr, + int *failPtr); +static Var * ArrayNext(Tcl_Interp *interp, ArraySearch *searchPtr, + int *failPtr); +static void ArrayDone(Tcl_Interp *interp, ArraySearch *searchPtr); +static int ArrayAborted(Tcl_Interp *interp, + ArraySearch *searchPtr, int dealloc); +static void ArraySearchFree(ArraySearch *searchPtr); +static int ArrayNames(Tcl_Interp *interp, Var *varPtr, + Tcl_Obj *filterObj, int filterType, + Tcl_Obj *listObj); +static int ArrayArgs(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], Tcl_Obj **varNameObjPtr, + Tcl_Obj **patternObjPtr, int *patternTypePtr); /* * Functions defined in this file that may be exported in the future for use * by the bytecode compiler and engine or to the public interface. */ @@ -228,11 +294,10 @@ static const Tcl_ObjType tclParsedVarNameType = { "parsedVarName", FreeParsedVarName, DupParsedVarName, NULL, NULL }; - Var * TclVarHashCreateVar( TclVarHashTable *tablePtr, const char *key, @@ -269,12 +334,12 @@ * is freed up. * *---------------------------------------------------------------------- */ -static inline void -CleanupVar( +void +TclCleanupVar( Var *varPtr, /* Pointer to variable that may be a candidate * for being expunged. */ Var *arrayPtr) /* Array that contains the variable, or NULL * if this variable isn't an array element. */ { @@ -295,20 +360,10 @@ } else { VarHashDeleteEntry(arrayPtr); } } } - -void -TclCleanupVar( - Var *varPtr, /* Pointer to variable that may be a candidate - * for being expunged. */ - Var *arrayPtr) /* Array that contains the variable, or NULL - * if this variable isn't an array element. */ -{ - CleanupVar(varPtr, arrayPtr); -} /* *---------------------------------------------------------------------- * * TclLookupVar -- @@ -915,11 +970,11 @@ * This function is used to locate a variable which is in an array's * hashtable given a pointer to the array's Var structure and the * element's name. * * Results: - * The return value is a pointer to the variable structure , or NULL if + * The return value is a pointer to the variable structure, or NULL if * the variable couldn't be found. * * If arrayPtr points to a variable that isn't an array and createPart1 * is 1, the corresponding variable will be converted to an array. * Otherwise, NULL is returned and an error message is left in the @@ -1042,10 +1097,1531 @@ } } } return varPtr; } + +/* + *---------------------------------------------------------------------- + * + * ArrayVar -- + * + * This function looks up or creates an array variable. The TCL_VAR_CREATE + * flag is used to enable creation mode. + * + * Results: + * If successful, the requested variable is returned. On failure, NULL is + * returned, and error information is placed in the interpreter result. If + * the error occurred within an array trace and traceFailPtr is not NULL, + * *traceFailPtr is set to 1. Non-trace errors are inhibited if flags does + * not contain TCL_LEAVE_ERR_MSG. + * + * Side effects: + * Array traces, if any, are executed. The variable is created if it does + * not exist and create mode is enabled. + * + *---------------------------------------------------------------------- + */ + +static Var * +ArrayVar( + Tcl_Interp *interp, /* Command interpreter in which varNamePtr is to + * be looked up. */ + Tcl_Obj *varNameObj, /* Name of array variable in interp. */ + int *traceFailPtr, /* Unless NULL, set to 1 on trace failure. */ + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_LEAVE_ERR_MSG, and + * TCL_VAR_CREATE. */ +{ + Var *varPtr, *arrayPtr; + const char *varName; + int create = !!(flags & TCL_VAR_CREATE); + + /* + * Strip TCL_VAR_CREATE from flags because no other function recognizes it. + */ + + flags &= ~TCL_VAR_CREATE; + + /* + * Locate the array variable. Unless in create mode, inhibit the normal + * variable lookup error messages in favor of the custom messages that will + * be generated below. + */ + + varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, + create ? flags : flags & ~TCL_LEAVE_ERR_MSG, "set", + create, create, &arrayPtr); + + /* + * In create mode with TCL_LEAVE_ERR_MSG set, keep any error messages that + * were generated. Furthermore, if the variable turned out be an array + * element, delete it and proceed to the common error routine below. + */ + + if (create) { + if (!varPtr && (flags & TCL_LEAVE_ERR_MSG)) { + return NULL; + } else if (arrayPtr) { + TclCleanupVar(varPtr, arrayPtr); + varPtr = NULL; + } + } + + if (varPtr) { + /* + * Special array trace used to keep the env array in sync for array + * names, array get, etc. + */ + + if (ArrayVarTrace(interp, varPtr, varNameObj) != TCL_OK) { + if (traceFailPtr) { + *traceFailPtr = 1; + } + return NULL; + } + + /* + * Verify that it is indeed an array variable. This test comes after the + * traces - the variable may actually become an array as an effect of + * said traces. + */ + + if (!create && (!TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + varPtr = NULL; + } + } + + /* + * Common error generation routine. This handles everything but creation + * errors (e.g. bad namespace) and traces (handled above). + */ + + if (!varPtr && (flags & TCL_LEAVE_ERR_MSG)) { + varName = TclGetString(varNameObj); + if (create) { + TclObjVarErrMsg(interp, varNameObj, NULL, "set", needArray, -1); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", varName, NULL); + } else { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("\"%s\" isn't an array", varName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL); + } + } + + return varPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayVarTrace -- + * + * Calls array traces on an array variable. + * + * Results: + * Returns TCL_OK if the array variable's array traces complete without + * error or if the array variable has no array traces. On error, returns + * TCL_ERROR and places error information in the interpreter result. + * + * Side effects: + * Array traces, if any, are executed. + * + *---------------------------------------------------------------------- + */ + +int +ArrayVarTrace( + Tcl_Interp *interp, /* Interpreter containing the variable. */ + Var *varPtr, /* Array variable structure pointer. */ + Tcl_Obj *varNameObj) /* Name of array variable. */ +{ + if ((varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) + && TclObjCallVarTraces((Interp *)interp, NULL, varPtr, varNameObj, + NULL, TCL_LEAVE_ERR_MSG | TCL_TRACE_ARRAY, + /*leaveErrMsg*/ 1, -1) != TCL_OK) { + return TCL_ERROR; + } else { + return TCL_OK; + } +} + +/* + *---------------------------------------------------------------------- + * + * ArrayFirst -- + * + * Finds the first element of an array. If a filter is specified, only + * elements matching the filter are found. + * + * Preconditions: + * The interp, varPtr, filterObj, and filterType fields of *searchPtr must + * have been initialized. + * + * Results: + * The first array element is returned, or NULL if there are no matching + * elements or on error, in which case *failPtr is set to 1. + * + * Side effects: + * *searchPtr is updated to track the progress of the enumeration. On + * error, detailed error information is placed into the interpreter result. + * + *---------------------------------------------------------------------- + */ + +static Var * +ArrayFirst( + Tcl_Interp *interp, /* Command interpreter in which the array + * variable is located. */ + ArraySearch *searchPtr, /* Array enumeration state structure. */ + int *failPtr) /* Set to 1 on error. */ +{ + TclVarHashTable *tablePtr = searchPtr->varPtr->value.tablePtr; + Var *varPtr; + + /* + * Exact matches and trivial glob matches can be completed immediately since + * they will only ever match one or zero elements. No need to iterate, just + * do a direct lookup, then fast-forward to the end of the hash table. + */ + + if (searchPtr->filterObj + && (searchPtr->filterType == TCL_MATCH_EXACT + || (searchPtr->filterType == TCL_MATCH_GLOB + && TclMatchIsTrivial(TclGetString(searchPtr->filterObj))))) { + varPtr = VarHashFindVar(tablePtr, searchPtr->filterObj); + searchPtr->search.tablePtr = &tablePtr->table; + searchPtr->search.nextIndex = tablePtr->table.numBuckets; + searchPtr->search.nextEntryPtr = NULL; + searchPtr->nextEntry = NULL; + + if (!varPtr || TclIsVarUndefined(varPtr)) { + return NULL; + } else { + return varPtr; + } + } + + /* + * For all other match types, find the first item (which may or may not + * match the filter) then chain to ArrayNext() to get the real first item. + */ + + searchPtr->nextEntry = VarHashFirstVar(tablePtr, &searchPtr->search); + return ArrayNext(interp, searchPtr, failPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ArrayNext -- + * + * Finds the next element of an array for a given search query. + * + * To peek at the next element without consuming it, copy the returned + * element to searchPtr->nextEntry. This causes the next invocation of + * ArrayNext() to return the same element again. + * + * Preconditions: + * ArrayFirst() must have been called on searchPtr. + * + * Results: + * The next array element is returned, or NULL if there are no matching + * elements remaining or on error, in which case *failPtr is set to 1 if + * failPtr is not NULL. + * + * Side effects: + * *searchPtr is updated to track the progress of the enumeration. On + * error, detailed error information is placed into the interpreter result. + * + *---------------------------------------------------------------------- + */ + +static Var * +ArrayNext( + Tcl_Interp *interp, /* Command interpreter in which the array + * variable is located. */ + ArraySearch *searchPtr, /* Array enumeration state structure. */ + int *failPtr) /* Set to 1 on error. */ +{ + Var *varPtr; + Tcl_Obj *nameObj; + int matched; + + /* + * Use the cached nextEntry left over from ArrayFirst() or [array anymore], + * or else get the next one from the hash table. + */ + + if (searchPtr->nextEntry) { + varPtr = searchPtr->nextEntry; + searchPtr->nextEntry = NULL; + } else { + varPtr = VarHashNextVar(&searchPtr->search); + } + + /* + * Iterate through the hash table until an element matches the filter or the + * end is reached. + */ + + for (; varPtr; varPtr = VarHashNextVar(&searchPtr->search)) { + if (!TclIsVarUndefined(varPtr)) { + /* + * If no filter, accept each defined element regardless of name. + */ + + if (!searchPtr->filterObj) { + return varPtr; + } + + /* + * Conditionally accept elements whose names match the filter. + */ + + nameObj = VarHashGetKey(varPtr); + if (searchPtr->filterType == TCL_MATCH_GLOB) { + if (Tcl_StringMatch(TclGetString(nameObj), + TclGetString(searchPtr->filterObj))) { + return varPtr; + } + } else if (searchPtr->filterType == TCL_MATCH_REGEXP) { + matched = Tcl_RegExpMatchObj(interp, nameObj, + searchPtr->filterObj); + if (matched < 0) { + if (failPtr) { + *failPtr = 1; + } + return NULL; + } else if (matched) { + return varPtr; + } + } else if (searchPtr->filterType == TCL_MATCH_EXACT) { + if (strcmp(TclGetString(nameObj), + TclGetString(searchPtr->filterObj)) == 0) { + return varPtr; + } + } else { + Tcl_Panic("invalid filter type: %u", searchPtr->filterType); + } + } + } + + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayDone -- + * + * Terminates and cleans up an array search query. + * + * Preconditions: + * The search argument must be the return value of Tcl_ArraySearchStart() + * and must not have been passed to Tcl_ArraySearchDone(). + * + * Results: + * The search query is completed. + * + * Side effects: + * Resources associated with the search are deallocated. + * + *---------------------------------------------------------------------- + */ + +void +ArrayDone( + Tcl_Interp *interp, /* Command interpreter in which the array + * variable is located. */ + ArraySearch *searchPtr) /* Array enumeration state structure. */ +{ + ArraySearch *prevPtr; + Tcl_HashEntry *hPtr = Tcl_FindHashEntry( + &((Interp *)interp)->varSearches, searchPtr->varPtr); + + /* + * Unhook the search from the list of searches associated with the + * variable. + */ + + if (searchPtr == Tcl_GetHashValue(hPtr)) { + if (searchPtr->nextPtr) { + Tcl_SetHashValue(hPtr, searchPtr->nextPtr); + } else { + searchPtr->varPtr->flags &= ~VAR_SEARCH_ACTIVE; + Tcl_DeleteHashEntry(hPtr); + } + } else { + for (prevPtr = Tcl_GetHashValue(hPtr);; prevPtr = prevPtr->nextPtr) { + if (prevPtr->nextPtr == searchPtr) { + prevPtr->nextPtr = searchPtr->nextPtr; + break; + } + } + } + + /* + * Deallocate the search object. + */ + + ArraySearchFree(searchPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ArrayAborted -- + * + * Checks if an array search was aborted due to array elements being added + * or removed or the array being unsed. Optionally deallocates it if so. + * + * Results: + * TCL_OK is returned if the array search did not abort. TCL_ERROR is + * returned if the array search did abort, and a message to that effect is + * placed in the interpreter result. If the dealloc argument is nonzero, + * the array search is also deallocated if it aborted. + * + * Side effects: + * Memory used by the search may be released to the storage allocator. + * + *---------------------------------------------------------------------- + */ + +int +ArrayAborted( + Tcl_Interp *interp, /* Command interpreter in which the array + * variable is located. */ + ArraySearch *searchPtr, /* Array enumeration state structure. */ + int dealloc) /* If nonzero, deallocate aborted searches. */ +{ + if (searchPtr->flags & SEARCH_ABORTED) { + if (dealloc) { + ArraySearchFree(searchPtr); + } + Tcl_SetResult(interp, "search aborted due to array change", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", "n/a", NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ArraySearchFree -- + * + * Deallocates an array search structure. + * + * Results: + * None. + * + * Side effects: + * Memory used by the search is released to the storage allocator. + * + *---------------------------------------------------------------------- + */ + +void +ArraySearchFree( + ArraySearch *searchPtr) /* Array enumeration state structure. */ +{ + if (searchPtr->name) { + Tcl_DecrRefCount(searchPtr->name); + } + Tcl_DecrRefCount(searchPtr->varNameObj); + if (searchPtr->filterObj) { + Tcl_DecrRefCount(searchPtr->filterObj); + } + ckfree(searchPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ArrayNames -- + * + * Obtains a list of array element names, optionally limited by a filter. + * + * Results: + * Normally, TCL_OK is returned, and the list of matching array element + * names is appended to listObj. On error, TCL_ERROR is returned, and the + * error information is placed in the interpreter's result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ArrayNames( + Tcl_Interp *interp, /* Interpreter, used to report regexp errors. */ + Var *varPtr, /* Array variable. */ + Tcl_Obj *filterObj, /* Element filter or NULL to accept all. */ + int filterType, /* TCL_MATCH_EXACT, _GLOB, or _REGEXP. */ + Tcl_Obj *listObj) /* List to which array names are appended. */ +{ + ArraySearch search; + int fail = 0, oldLen, newLen; + + /* + * Ensure output object is a list. Also get its length in case there is + * trouble and changes need to be rolled back. Such a failure should never + * occur because it requires a regular expression to initially succeed then + * return error on a subsequent evaluation, but handle it anyway because + * it's easy to do. + */ + + if (Tcl_ListObjLength(interp, listObj, &oldLen) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Begin the search. + */ + + search.varPtr = varPtr; + search.filterObj = filterObj; + search.filterType = filterType; + search.nextEntry = NULL; + search.flags = 0; + varPtr = ArrayFirst(interp, &search, &fail); + + /* + * Enumerate the array. + */ + + for (; varPtr; varPtr = ArrayNext(interp, &search, &fail)) { + Tcl_ListObjAppendElement(interp, listObj, VarHashGetKey(varPtr)); + } + + /* + * On failure, roll back changes to output list. + */ + + if (fail) { + Tcl_ListObjLength(interp, listObj, &newLen); + Tcl_ListObjReplace(interp, listObj, oldLen, newLen - oldLen, 0, NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayArgs -- + * + * Common argument parser for numerous [array] commands, namely: + * startsearch, exists, get, names, size, and unset. + * + * Results: + * Arguments are parsed, results are written to caller variables, and + * TCL_OK is returned. On failure, TCL_ERROR is returned, and error + * information is logged to the interpreter. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ArrayArgs( + Tcl_Interp *interp, /* Interpreter into which errors are logged. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[], /* Argument vector. */ + Tcl_Obj **varNameObjPtr, /* Location to write variable name. */ + Tcl_Obj **filterObjPtr, /* Location to write filter pattern. */ + int *filterTypePtr) /* Location to write filter type code. */ +{ + static const struct { + const char *name; + int type; + } options[] = { + {"-exact" , TCL_MATCH_EXACT }, + {"-glob" , TCL_MATCH_GLOB }, + {"-regexp" , TCL_MATCH_REGEXP }, + {NULL , 0 }, + }; + enum {OPT_EXACT, OPT_GLOB, OPT_REGEXP} mode = OPT_GLOB; + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?"); + return TCL_ERROR; + } + + if (objc == 4 && Tcl_GetIndexFromObjStruct(interp, objv[2], options, + sizeof(*options), "option", 0, (int *)&mode) != TCL_OK) { + return TCL_ERROR; + } + + *varNameObjPtr = objv[1]; + *filterObjPtr = objc > 2 ? objv[objc - 1] : NULL; + *filterTypePtr = options[mode].type; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArraySet -- + * + * Set the elements of an array. If there are no elements to set, create + * an empty array. + * + * Results: + * A standard Tcl result object. + * + * Side effects: + * A variable will be created if one does not already exist. + * Callers must Incr part1Ptr if they plan to Decr it. + * Array and variable set traces are executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ArraySet( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *part1Ptr, /* The array name. */ + Tcl_Obj *dictPtr, /* The array elements list or dict. If this is + * NULL, create an empty array. */ + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY and + * TCL_NAMESPACE_ONLY. */ +{ + Var *varPtr; + int result, i; + + if (!(varPtr = ArrayVar(interp, part1Ptr, NULL, + flags | TCL_LEAVE_ERR_MSG | TCL_VAR_CREATE))) { + return TCL_ERROR; + } + + if (dictPtr == NULL) { + goto ensureArray; + } + + /* + * Install the contents of the dictionary or list into the array. + */ + + if (dictPtr->typePtr == &tclDictType) { + Tcl_Obj *keyPtr, *valuePtr; + Tcl_DictSearch search; + int done; + + if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) { + return TCL_ERROR; + } + if (done == 0) { + /* + * Empty, so we'll just force the array to be properly existing + * instead. + */ + + goto ensureArray; + } + + /* + * Don't need to look at result of Tcl_DictObjFirst as we've just + * successfully used a dictionary operation on the same object. + */ + + for (Tcl_DictObjFirst(interp, dictPtr, &search, + &keyPtr, &valuePtr, &done) ; !done ; + Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) { + /* + * At this point, it would be nice if the key was directly usable + * by the array. This isn't the case though. + */ + + Var *elemVarPtr = TclLookupArrayElement(interp, part1Ptr, + keyPtr, flags | TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); + + if ((elemVarPtr == NULL) || + (TclPtrSetVar(interp, elemVarPtr, varPtr, part1Ptr, + keyPtr, valuePtr, flags | TCL_LEAVE_ERR_MSG, -1) == NULL)) { + Tcl_DictObjDone(&search); + return TCL_ERROR; + } + } + return TCL_OK; + } else { + /* + * Not a dictionary, so assume (and convert to, for backward- + * -compatibility reasons) a list. + */ + + int elemLen; + Tcl_Obj **elemPtrs, *copyListObj; + + result = TclListObjGetElements(interp, dictPtr, + &elemLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (elemLen & 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "list must have an even number of elements", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL); + return TCL_ERROR; + } + if (elemLen == 0) { + goto ensureArray; + } + + /* + * We needn't worry about traces invalidating arrayPtr: should that be + * the case, TclPtrSetVar will return NULL so that we break out of the + * loop and return an error. + */ + + copyListObj = TclListObjCopy(NULL, dictPtr); + for (i=0 ; ivalue.tablePtr = ckalloc(sizeof(TclVarHashTable)); + TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArrayUnset -- + * + * Unsets array elements, optionally limited by a filter. It is not an + * error for the filter to not match any elements or for the variable to + * not exist or not be an array. + * + * Results: + * The requested array elements are unset, and TCL_OK is returned. On trace + * or filter match error, TCL_ERROR is returned and error information is + * placed in the interpreter result. + * + * Side effects: + * Array and unset traces are executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ArrayUnset( + Tcl_Interp *interp, /* Interpreter containing the variable. */ + Tcl_Obj *part1Ptr, /* Name of the array variable. */ + Tcl_Obj *part2Ptr, /* Element filter or NULL to unset all. */ + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, and at most one of + * TCL_MATCH_EXACT, _GLOB, and _REGEXP. */ +{ + ArraySearch search; + int fail = 0, filterType = flags & TCL_MATCH; + Var *varPtr, *elemPtr, *protectedElemPtr; + + /* + * Locate the array variable. This has the side effect of executing any + * array traces. If the variable does not exist, exit successfully. + */ + + if (!(varPtr = ArrayVar(interp, part1Ptr, &fail, 0))) { + return fail ? TCL_ERROR : TCL_OK; + } + + /* + * When no filter is given, unset the whole array. + */ + + if (!part2Ptr) { + return TclObjUnsetVar2(interp, part1Ptr, NULL, flags); + } + + /* + * With an exact match or trivial pattern, unset the single element. + */ + + if (filterType == TCL_MATCH_EXACT || (filterType == TCL_MATCH_GLOB + && TclMatchIsTrivial(TclGetString(part2Ptr)))) { + elemPtr = VarHashFindVar(varPtr->value.tablePtr, part2Ptr); + if (!elemPtr || TclIsVarUndefined(elemPtr)) { + return TCL_OK; + } else { + return TclPtrUnsetVar(interp, elemPtr, varPtr, + part1Ptr, part2Ptr, 0, -1); + } + } + + /* + * Prepare to iterate through all elements of the array. + */ + + search.varPtr = varPtr; + search.filterObj = part2Ptr; + search.filterType = filterType; + search.flags = 0; + elemPtr = ArrayFirst(interp, &search, &fail); + + /* + * Non-trivial case (well, deeply tricky really). We peek inside the hash + * iterator in order to allow us to guarantee that the following element + * in the array will not be scrubbed until we have dealt with it. This + * stops the overall iterator from ending up pointing into deallocated + * memory. [Bug 2939073] + */ + + protectedElemPtr = NULL; + for (; elemPtr; elemPtr = ArrayNext(interp, &search, &fail)) { + /* + * Drop the extra ref immediately. We don't need to free it at this + * point though; we'll be unsetting it if necessary soon. + */ + + if (protectedElemPtr == elemPtr) { + VarHashRefCount(protectedElemPtr)--; + } + + /* + * Peek ahead at the next item in the search and guard it against being + * deallocated in the scenario where the unset trace on the current + * element causes the next element to be unset as well. + * + * Curiosity: each hash table bucket is a linked list to which new items + * are prepended, so "next" usually means the latest element in the same + * bucket that was set before the current element. + */ + + if ((search.nextEntry = ArrayNext(interp, &search, &fail))) { + VarHashRefCount(protectedElemPtr)++; + } + protectedElemPtr = search.nextEntry; + + /* + * If the variable is undefined, clean it out as it has been hit by + * something else (i.e., an unset trace). + */ + + if (TclIsVarUndefined(elemPtr)) { + TclCleanupVar(elemPtr, varPtr); + } else if (TclPtrUnsetVar(interp, elemPtr, varPtr, part1Ptr, + VarHashGetKey(elemPtr), 0, -1) != TCL_OK) { + /* + * If we incremented a refcount, we must decrement it here as we + * will not be coming back properly due to the error. + */ + + if (protectedElemPtr) { + VarHashRefCount(protectedElemPtr)--; + TclCleanupVar(protectedElemPtr, varPtr); + } + return TCL_ERROR; + } + } + + return fail ? TCL_ERROR : TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArrayGet -- + * + * This function loads the contents of an array into a dict. It is not an + * error for the variable to not exist or not be an array; in this case, + * the dict is not modified, as if the variable were an empty array. + * + * Results: + * The array is loaded into the specified dict. The array element names and + * values become the dict keys and values, respectively. If a filter is + * supplied, only the elements whose names match the filter are loaded. + * + * If the output dict isn't initially empty, the new keys and values take + * precedence over its initial contents. This can be used to merge multiple + * arrays, or multiple collections of elements from a single array obtained + * by different filters, into a single dict. There is a mild performance + * penalty when the output dict isn't initially empty due to the need to + * maintain a rollback dict in case an array trace or read trace unsets the + * array during the execution of this function. + * + * The return value is TCL_OK on success and TCL_ERROR on trace or filter + * match error. + * + * Side effects: + * Array and variable read traces, if any, are executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ArrayGet( + Tcl_Interp *interp, /* Interpreter in which to look up variable. */ + Tcl_Obj *part1Ptr, /* Name of array variable. */ + Tcl_Obj *part2Ptr, /* Element filter or NULL to read all. */ + Tcl_Obj *dictPtr, /* Dict object to load array data into. */ + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY and + * TCL_NAMESPACE_ONLY, and at most one of + * TCL_MATCH_EXACT, _GLOB, and _REGEXP. */ +{ + Tcl_Obj *nameListObj, *rollbackObj, **nameObjPtr, *valueObj; + Var *varPtr; + int fail = 0, filterType = flags & TCL_MATCH, i, count, result; + + /* + * Locate the array variable. Report trace failures as errors. If the + * variable is a scalar or does not exist, treat it like an empty array. + */ + + if (!(varPtr = ArrayVar(interp, part1Ptr, &fail, flags))) { + return fail ? TCL_ERROR : TCL_OK; + } + + /* + * Confirm the output structure forms a valid dict. It's also important to + * check whether it's initially empty or not. + */ + + if (Tcl_DictObjSize(interp, dictPtr, &count) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Get the list of element names matching the filter. + */ + + TclNewObj(nameListObj); + Tcl_IncrRefCount(nameListObj); + if (ArrayNames(interp, varPtr, part2Ptr, filterType, + nameListObj) != TCL_OK) { + Tcl_DecrRefCount(nameListObj); + return TCL_ERROR; + } + + /* + * If the output dict wasn't initially empty, prepare to undo any changes + * made to it in case an error occurs. + */ + + if (count) { + TclNewObj(rollbackObj); + Tcl_IncrRefCount(rollbackObj); + } else { + rollbackObj = NULL; + } + + /* + * Make sure the Var structure of the array is not removed by a trace while + * we're working. + */ + + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)++; + } + + /* + * Load the array keys and values into the output dict. + */ + + Tcl_ListObjGetElements(interp, nameListObj, &count, &nameObjPtr); + result = TCL_OK; + for (i = 0; i < count; ++i, ++nameObjPtr) { + /* + * If rollback is enabled, before loading each new value, remember the + * old value already present in the output dict. + */ + + if (rollbackObj) { + Tcl_DictObjGet(interp, dictPtr, *nameObjPtr, &valueObj); + if (valueObj) { + Tcl_DictObjPut(interp, rollbackObj, *nameObjPtr, valueObj); + } + } + + /* + * Try to get the array element value, but beware of traces. + */ + + valueObj = Tcl_ObjGetVar2(interp, part1Ptr, *nameObjPtr, + TCL_LEAVE_ERR_MSG); + + if (valueObj) { + /* + * If the array element was found, load it into the output dict, an + * operation which cannot fail since the output was already + * confirmed to be a valid dict. + */ + + Tcl_DictObjPut(interp, dictPtr, *nameObjPtr, valueObj); + } else if (!TclIsVarArray(varPtr)) { + /* + * On error (specifically, if a trace deleted the array), restore + * the output dict to the way it was when this function was called. + * + * If the element was unset by a trace, proceed as if it never + * existed in the first place, provided the array still exists. + */ + + if (rollbackObj) { + count = i; + nameObjPtr -= i; + for (i = 0; i < count; ++i, ++nameObjPtr) { + Tcl_DictObjGet(interp, rollbackObj, *nameObjPtr, &valueObj); + if (valueObj) { + Tcl_DictObjPut(interp, dictPtr, *nameObjPtr, valueObj); + } else { + Tcl_DictObjRemove(interp, dictPtr, *nameObjPtr); + } + } + } else { + Tcl_SetStringObj(dictPtr, NULL, 0); + } + + result = TCL_ERROR; + break; + } + } + + /* + * Clean up internal data structures, then report success or failure. + */ + + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)--; + } + if (rollbackObj) { + Tcl_DecrRefCount(rollbackObj); + } + Tcl_DecrRefCount(nameListObj); + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArrayNames -- + * + * Obtains a list of array element names, optionally limited by a filter. + * + * Results: + * Normally, TCL_OK is returned, and the list of matching array element + * names is appended to listPtr. On error, TCL_ERROR is returned, and the + * error information is placed in the interpreter's result. If part1Ptr + * does not name an array, TCL_OK is returned and listPtr is unmodified. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ArrayNames( + Tcl_Interp *interp, /* Command interpreter in which part1Ptr is to + * be looked up. */ + Tcl_Obj *part1Ptr, /* Name of array variable in interp. */ + Tcl_Obj *part2Ptr, /* Element filter or NULL to accept all. */ + Tcl_Obj *listPtr, /* List to which array names are appended. */ + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY and + * TCL_NAMESPACE_ONLY, and at most one of + * TCL_MATCH_EXACT, _GLOB, and _REGEXP. */ +{ + int traceFail = 0; + Var *varPtr = ArrayVar(interp, part1Ptr, &traceFail, flags); + + if (varPtr) { + return ArrayNames(interp, varPtr, part2Ptr, flags & TCL_MATCH, listPtr); + } else if (traceFail) { + return TCL_ERROR; + } else { + return TCL_OK; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArraySize -- + * + * This function reports the number of elements in an array variable. It + * provides C-level access to [array size] functionality. If part2Ptr is + * not NULL, only array elements whose names match part2Ptr are counted + * toward the return value. The interpretation of part2Ptr is controlled by + * the TCL_MATCH_* bits within flags. + * + * Results: + * The return value is normally TCL_OK; in this case *intPtr will be set to + * the integer count of array elements whose names match the given filter. + * If varNamePtr does not name an array, TCL_OK is returned and *intPtr is + * set to 0. If an array trace error occurs, or if there is an error in the + * filter (e.g. bad regular expression), TCL_ERROR is returned and an error + * message is left in the interpreter's result. + * + * Side effects: + * Array traces, if any, are executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ArraySize( + Tcl_Interp *interp, /* Command interpreter in which part1Ptr is to + * be looked up. */ + Tcl_Obj *part1Ptr, /* Name of array variable in interp. */ + Tcl_Obj *part2Ptr, /* Element filter or NULL to accept all. */ + int *intPtr, /* Location to which size is written. */ + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY and + * TCL_NAMESPACE_ONLY, and at most one of + * TCL_MATCH_EXACT, _GLOB, and _REGEXP. */ +{ + Var *varPtr; + ArraySearch search; + int fail = 0, size = 0; + + if ((varPtr = ArrayVar(interp, part1Ptr, &fail, flags))) { + /* + * Determine the size by counting the number of times ArrayFirst() or + * ArrayNext() returns non-NULL. + */ + + search.varPtr = varPtr; + search.filterObj = part2Ptr; + search.filterType = flags & TCL_MATCH; + search.flags = 0; + for (varPtr = ArrayFirst(interp, &search, &fail); varPtr; + varPtr = ArrayNext(interp, &search, &fail)) { + ++size; + } + } + + if (fail) { + return TCL_ERROR; + } + + *intPtr = size; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArrayExists -- + * + * This function checks if an array or array element exists. If part2Ptr is + * NULL, the existence of the array is checked. If part2Ptr is not NULL, + * this function instead checks if at least one array element name matches + * the filter specified by part2Ptr and the TCL_MATCH_* bits within flags. + * + * Results: + * *intPtr is set to 1 or 0 if the array or array element does or does not + * exist, and TCL_OK is returned. *intPtr is also set to 0 if a variable + * with the given name exists but is not an array, as well as in event of + * lookup error such as nonexistent namespace. If an array trace error + * occurs, TCL_ERROR is returned and *intPtr is not modified. + * + * Side effects: + * Array traces, if any, are executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ArrayExists( + Tcl_Interp *interp, /* Interpreter in which to look up variable. */ + Tcl_Obj *part1Ptr, /* Name of array variable in interp. */ + Tcl_Obj *part2Ptr, /* Element to check or NULL to check array. */ + int *intPtr, /* Set to 1 if array exists, 0 if not. */ + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY and + * TCL_NAMESPACE_ONLY, and at most one of + * TCL_MATCH_EXACT, _GLOB, and _REGEXP. */ +{ + ArraySearch search; + int fail = 0; + Var *varPtr = ArrayVar(interp, part1Ptr, &fail, flags); + + /* + * If the array lookup succeeded and a filter was specified, attempt to find + * the first element which matches the filter. + */ + + if (varPtr && part2Ptr) { + search.varPtr = varPtr; + search.filterObj = part2Ptr; + search.filterType = flags & TCL_MATCH; + search.flags = 0; + varPtr = ArrayFirst(interp, &search, &fail); + } + + if (varPtr) { + *intPtr = 1; + } else if (fail) { + return TCL_ERROR; + } else { + *intPtr = 0; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArraySearchStart -- + * + * This function initiates an array search, i.e. step-by-step array element + * enumeration. It provides C-level access to [array startsearch]. The + * returned value is used to obtain one array element name at a time. If + * part2Ptr is not NULL, only array elements whose names match part2Ptr are + * returned by future calls to Tcl_ArraySearchNext(). The interpretation of + * part2Ptr is controlled by the TCL_MATCH_* bits within flags. + * + * Important note: + * Unlike all the other Tcl_Array*() functions, this function reports array + * existence errors rather than treating nonexistent and scalar variables + * as if they were empty arrays. + * + * Results: + * A new array search is created and returned. If part1Ptr does not name an + * array, if there is a problem with the filter, or if an array trace error + * occurred, no search is created, NULL is returned, and error information + * is placed in the interpreter. + * + * Side effects: + * On success, the search is allocated on the heap. To avoid a memory leak, + * the search must be deallocated by Tcl_ArraySearchDone() when complete. + * Array traces, if any, are executed. + * + *---------------------------------------------------------------------- + */ + +Tcl_ArraySearch +Tcl_ArraySearchStart( + Tcl_Interp *interp, /* Command interpreter in which part1Ptr is to + * be looked up. */ + Tcl_Obj *part1Ptr, /* Name of array variable in interp. */ + Tcl_Obj *part2Ptr, /* Element filter or NULL to accept all. */ + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY and + * TCL_NAMESPACE_ONLY, and at most one of + * TCL_MATCH_EXACT, _GLOB, and _REGEXP. */ +{ + Interp *iPtr = (Interp *)interp; + Var *varPtr = ArrayVar(interp, part1Ptr, NULL, flags | TCL_LEAVE_ERR_MSG); + Tcl_HashEntry *hPtr; + int isNew, fail = 0; + ArraySearch search, *searchPtr; + + /* + * Handle the possible error cases before performing any allocations. + */ + + if (!varPtr) { + return NULL; + } + + search.nextEntry = ArrayFirst(interp, &search, &fail); + if (!search.nextEntry && fail) { + return NULL; + } + search.name = NULL; + search.varNameObj = part1Ptr; + search.varPtr = varPtr; + search.filterObj = part2Ptr; + search.filterType = flags & TCL_MATCH; + search.flags = KEEP_ON_ABORT; + + /* + * Make a new array search. + */ + + hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew); + if (isNew) { + search.id = 1; + varPtr->flags |= VAR_SEARCH_ACTIVE; + search.nextPtr = NULL; + } else { + search.id = ((ArraySearch *)Tcl_GetHashValue(hPtr))->id + 1; + search.nextPtr = Tcl_GetHashValue(hPtr); + } + Tcl_IncrRefCount(search.varNameObj); + if (part2Ptr) { + Tcl_IncrRefCount(part2Ptr); + } + searchPtr = ckalloc(sizeof(*searchPtr)); + *searchPtr = search; + Tcl_SetHashValue(hPtr, searchPtr); + + return searchPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArraySearchPeek -- + * + * Finds the next element of an array for a given search query. Unlike + * Tcl_ArraySearchNext(), the only side effect is array traces, so the + * search query state is not advanced and the element is not consumed. + * + * Preconditions, results: + * Same as Tcl_ArraySearchNext(). + * + * Side effects: + * Array traces, if any, are executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ArraySearchPeek( + Tcl_Interp *interp, /* Command interpreter in which the array + * variable is located. */ + Tcl_ArraySearch search, /* Prior return from Tcl_ArraySearchStart(). */ + Tcl_Obj **keyPtrPtr, /* Location to which pointer to next array + * element name is written. NULL is written when + * the end of the array has been encountered. */ + Tcl_Obj **valuePtrPtr) /* If not NULL, location to which pointer to + * next array element value is written. NULL is + * written when at the end of the array. */ +{ + Tcl_Obj *keyObj, *valueObj; + + /* + * Report aborted searches. + */ + + if (ArrayAborted(interp, search, 0) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Execute array traces and report any errors that may arise. + */ + + if (ArrayVarTrace(interp, search->varPtr, search->varNameObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Get the next array element, but push it back into the nextEntry buffer so + * that it will be reused when ArrayNext() is called again. + */ + + if ((search->nextEntry = ArrayNext(interp, search, NULL))) { + /* + * If not at the end of the array, get the element name and (if an + * output location was given) element value. Report any errors that may + * occur due to reading the element value if it is requested. + */ + + keyObj = VarHashGetKey(search->nextEntry); + if (valuePtrPtr) { + if ((valueObj = Tcl_ObjGetVar2(interp, search->varNameObj, keyObj, + TCL_LEAVE_ERR_MSG))) { + *valuePtrPtr = valueObj; + } else { + return TCL_ERROR; + } + } + *keyPtrPtr = keyObj; + } else { + /* + * At the end of the array, store NULL for the element name and (if an + * output location was given) element value. + */ + + *keyPtrPtr = NULL; + if (valuePtrPtr) { + *valuePtrPtr = NULL; + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArraySearchNext -- + * + * Finds the next element of an array for a given search query. + * + * Preconditions: + * The search argument must be the return value of Tcl_ArraySearchStart() + * and must not have been passed to Tcl_ArraySearchDone(). + * + * Results: + * The next array element name is written to *keyPtrPtr. If valuePtrPtr is + * not NULL, the array element value is written to *valuePtrPtr. If there + * are no more array elements, NULL is written instead. If an array trace + * or variable read trace error occurs, TCL_ERROR is returned and error + * information is placed in the interpreter result. + * + * Side effects: + * The search data structure is updated such that successive invocations of + * this function will return successive array element names. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ArraySearchNext( + Tcl_Interp *interp, /* Command interpreter in which the array + * variable is located. */ + Tcl_ArraySearch search, /* Prior return from Tcl_ArraySearchStart(). */ + Tcl_Obj **keyPtrPtr, /* Location to which pointer to next array + * element name is written. NULL is written when + * the end of the array has been encountered. */ + Tcl_Obj **valuePtrPtr) /* If not NULL, location to which pointer to + * next array element value is written. NULL is + * written when at the end of the array. */ +{ + /* + * Let Tcl_ArraySearchPeek() do all the work, then clear the search + * structure's nextEntry buffer so that the search will advance. + */ + + if (Tcl_ArraySearchPeek(interp, search, keyPtrPtr, valuePtrPtr) != TCL_OK) { + return TCL_ERROR; + } + + search->nextEntry = NULL; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArraySearchDone -- + * + * Terminates and cleans up an array search query. + * + * Preconditions: + * The search argument must be the return value of Tcl_ArraySearchStart() + * and must not have been passed to Tcl_ArraySearchDone(). + * + * Results: + * Normally, the search query is completed, and TCL_OK is returned. If an + * array trace has an error, TCL_ERROR is returned and error information is + * placed in the interpreter result. + * + * Side effects: + * Resources associated with the search are deallocated. Array traces, if + * any, are executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ArraySearchDone( + Tcl_Interp *interp, /* Command interpreter in which the array + * variable is located. */ + Tcl_ArraySearch search) /* Prior return from Tcl_ArraySearchStart(). */ +{ + /* + * Report and deallocate aborted searches. + */ + + if (ArrayAborted(interp, search, 1) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Execute array traces and report any errors that may arise. + */ + + if (ArrayVarTrace(interp, search->varPtr, search->varNameObj) != TCL_OK) { + return TCL_ERROR; + } + + ArrayDone(interp, search); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArrayStatistics -- + * + * Returns statistics about the distribution of data within the hash table + * that represents the array. This information includes the number of + * entries in the table, the number of buckets, and the utilization of the + * buckets. + * + * Results: + * Normally, TCL_OK is returned, and the statistics information is appended + * to stringPtr. If part1Ptr does not name an array, or if an array trace + * error occurs, TCL_ERROR is returned and error information is left in the + * interpreter result. + * + * Side effects: + * Array traces, if any, are executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ArrayStatistics( + Tcl_Interp *interp, /* Interpreter containing the variable. */ + Tcl_Obj *part1Ptr, /* Name of the array variable. */ + Tcl_Obj *stringPtr, /* String to which statistics is appended. */ + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY and + * TCL_NAMESPACE_ONLY. */ +{ + Var *varPtr = ArrayVar(interp, part1Ptr, NULL, flags | TCL_LEAVE_ERR_MSG); + char *stats; + + if (!varPtr) { + return TCL_ERROR; + } + + stats = Tcl_HashStats((Tcl_HashTable *)varPtr->value.tablePtr); + Tcl_AppendToObj(stringPtr, stats, -1); + ckfree(stats); + + return TCL_OK; +} /* *---------------------------------------------------------------------- * * Tcl_GetVar -- @@ -2203,11 +3779,11 @@ * its value object, if any, was decremented above. */ if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)--; - CleanupVar(varPtr, arrayPtr); + TclCleanupVar(varPtr, arrayPtr); } return result; } /* @@ -2370,11 +3946,11 @@ Var *linkPtr = dummyVar.value.linkPtr; if (TclIsVarInHash(linkPtr)) { VarHashRefCount(linkPtr)--; - CleanupVar(linkPtr, NULL); + TclCleanupVar(linkPtr, NULL); } } /* * If the variable was a namespace variable, decrement its reference @@ -2660,179 +4236,10 @@ } /* *---------------------------------------------------------------------- * - * TclArraySet -- - * - * Set the elements of an array. If there are no elements to set, create - * an empty array. This routine is used by the Tcl_ArrayObjCmd and by the - * TclSetupEnv routine. - * - * Results: - * A standard Tcl result object. - * - * Side effects: - * A variable will be created if one does not already exist. - * Callers must Incr arrayNameObj if they pland to Decr it. - * - *---------------------------------------------------------------------- - */ - -int -TclArraySet( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *arrayNameObj, /* The array name. */ - Tcl_Obj *arrayElemObj) /* The array elements list or dict. If this is - * NULL, create an empty array. */ -{ - Var *varPtr, *arrayPtr; - int result, i; - - varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, - /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1, - /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { - return TCL_ERROR; - } - if (arrayPtr) { - CleanupVar(varPtr, arrayPtr); - TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(arrayNameObj), NULL); - return TCL_ERROR; - } - - if (arrayElemObj == NULL) { - goto ensureArray; - } - - /* - * Install the contents of the dictionary or list into the array. - */ - - if (arrayElemObj->typePtr == &tclDictType) { - Tcl_Obj *keyPtr, *valuePtr; - Tcl_DictSearch search; - int done; - - if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { - return TCL_ERROR; - } - if (done == 0) { - /* - * Empty, so we'll just force the array to be properly existing - * instead. - */ - - goto ensureArray; - } - - /* - * Don't need to look at result of Tcl_DictObjFirst as we've just - * successfully used a dictionary operation on the same object. - */ - - for (Tcl_DictObjFirst(interp, arrayElemObj, &search, - &keyPtr, &valuePtr, &done) ; !done ; - Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) { - /* - * At this point, it would be nice if the key was directly usable - * by the array. This isn't the case though. - */ - - Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, - keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); - - if ((elemVarPtr == NULL) || - (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj, - keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) { - Tcl_DictObjDone(&search); - return TCL_ERROR; - } - } - return TCL_OK; - } else { - /* - * Not a dictionary, so assume (and convert to, for backward- - * -compatibility reasons) a list. - */ - - int elemLen; - Tcl_Obj **elemPtrs, *copyListObj; - - result = TclListObjGetElements(interp, arrayElemObj, - &elemLen, &elemPtrs); - if (result != TCL_OK) { - return result; - } - if (elemLen & 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "list must have an even number of elements", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL); - return TCL_ERROR; - } - if (elemLen == 0) { - goto ensureArray; - } - - /* - * We needn't worry about traces invalidating arrayPtr: should that be - * the case, TclPtrSetVar will return NULL so that we break out of the - * loop and return an error. - */ - - copyListObj = TclListObjCopy(NULL, arrayElemObj); - for (i=0 ; ivalue.tablePtr = ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * ArrayStartSearchCmd -- * * This object-based function is invoked to process the "array * startsearch" Tcl command. See the user documentation for details on * what it does. @@ -2845,101 +4252,50 @@ * *---------------------------------------------------------------------- */ /* ARGSUSED */ - -static Var * -VerifyArray( - Tcl_Interp *interp, - Tcl_Obj *varNameObj) -{ - Interp *iPtr = (Interp *) interp; - const char *varName = TclGetString(varNameObj); - Var *arrayPtr; - - /* - * Locate the array variable. - */ - - Var *varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return NULL; - } - } - - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", varName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL); - return NULL; - } - - return varPtr; -} - static int ArrayStartSearchCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr; - Tcl_HashEntry *hPtr; - int isNew; + Tcl_Obj *varNameObj, *filterObj, *tokenObj; ArraySearch *searchPtr; + int filterType; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); + if (ArrayArgs(interp, objc, objv, &varNameObj, + &filterObj, &filterType) != TCL_OK) { return TCL_ERROR; } - varPtr = VerifyArray(interp, objv[1]); - if (varPtr == NULL) { + if (!(searchPtr = Tcl_ArraySearchStart(interp, varNameObj, filterObj, + TCL_LEAVE_ERR_MSG | filterType))) { return TCL_ERROR; } /* - * Make a new array search with a free name. + * Give the search a name so it can be looked up by other array commands. + */ + + tokenObj = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, + TclGetString(varNameObj)); + searchPtr->name = tokenObj; + Tcl_IncrRefCount(tokenObj); + + /* + * Clear the KEEP_ON_ABORT flag which was set by Tcl_ArraySearchStart() so + * the search structure will automatically be deallocated should the search + * terminate early due to array elements being added or removed or the array + * itself being unset. */ - searchPtr = ckalloc(sizeof(ArraySearch)); - hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew); - if (isNew) { - searchPtr->id = 1; - varPtr->flags |= VAR_SEARCH_ACTIVE; - searchPtr->nextPtr = NULL; - } else { - searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1; - searchPtr->nextPtr = Tcl_GetHashValue(hPtr); - } - searchPtr->varPtr = varPtr; - searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, - &searchPtr->search); - Tcl_SetHashValue(hPtr, searchPtr); - searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(objv[1])); - Tcl_IncrRefCount(searchPtr->name); - Tcl_SetObjResult(interp, searchPtr->name); + searchPtr->flags = 0; + + Tcl_SetObjResult(interp, tokenObj); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2967,22 +4323,21 @@ Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Var *varPtr; Tcl_Obj *varNameObj, *searchObj; - int gotValue; ArraySearch *searchPtr; + int gotValue, fail = 0; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); return TCL_ERROR; } varNameObj = objv[1]; searchObj = objv[2]; - varPtr = VerifyArray(interp, varNameObj); - if (varPtr == NULL) { + if (!(varPtr = ArrayVar(interp, varNameObj, NULL, TCL_LEAVE_ERR_MSG))) { return TCL_ERROR; } /* * Get the search. @@ -2992,28 +4347,23 @@ if (searchPtr == NULL) { return TCL_ERROR; } /* - * Scan forward to find if there are any further elements in the array - * that are defined. + * Scan forward to find if there are any further matching elements in the + * array. Put the found element (if any) into searchPtr->nextEntry so that + * it is not consumed and is available for the next call. */ - while (1) { - if (searchPtr->nextEntry != NULL) { - varPtr = VarHashGetValue(searchPtr->nextEntry); - if (!TclIsVarUndefined(varPtr)) { - gotValue = 1; - break; - } - } - searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); - if (searchPtr->nextEntry == NULL) { - gotValue = 0; - break; - } - } + if ((searchPtr->nextEntry = ArrayNext(interp, searchPtr, &fail))) { + gotValue = 1; + } else if (fail) { + return TCL_ERROR; + } else { + gotValue = 0; + } + Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[gotValue]); return TCL_OK; } /* @@ -3040,11 +4390,11 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Var *varPtr; + Var *varPtr, *elemPtr; Tcl_Obj *varNameObj, *searchObj; ArraySearch *searchPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); @@ -3051,48 +4401,31 @@ return TCL_ERROR; } varNameObj = objv[1]; searchObj = objv[2]; - varPtr = VerifyArray(interp, varNameObj); - if (varPtr == NULL) { + if (!(varPtr = ArrayVar(interp, varNameObj, NULL, TCL_LEAVE_ERR_MSG))) { return TCL_ERROR; } /* * Get the search. */ - searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj); - if (searchPtr == NULL) { + if (!(searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj))) { return TCL_ERROR; } /* - * Get the next element from the search, or the empty string on - * exhaustion. Note that the [array anymore] command may well have already - * pulled a value from the hash enumeration, so we have to check the cache - * there first. + * Get the next element from the search, or the empty string on exhaustion. */ - while (1) { - Tcl_HashEntry *hPtr = searchPtr->nextEntry; - - if (hPtr == NULL) { - hPtr = Tcl_NextHashEntry(&searchPtr->search); - if (hPtr == NULL) { - return TCL_OK; - } - } else { - searchPtr->nextEntry = NULL; - } - varPtr = VarHashGetValue(hPtr); - if (!TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, VarHashGetKey(varPtr)); - return TCL_OK; - } - } + if ((elemPtr = ArrayNext(interp, searchPtr, NULL))) { + Tcl_SetObjResult(interp, VarHashGetKey(elemPtr)); + } + + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -3117,60 +4450,39 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; Var *varPtr; - Tcl_HashEntry *hPtr; Tcl_Obj *varNameObj, *searchObj; - ArraySearch *searchPtr, *prevPtr; + ArraySearch *searchPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); return TCL_ERROR; } varNameObj = objv[1]; searchObj = objv[2]; - varPtr = VerifyArray(interp, varNameObj); - if (varPtr == NULL) { + if (!(varPtr = ArrayVar(interp, varNameObj, NULL, TCL_LEAVE_ERR_MSG))) { return TCL_ERROR; } /* * Get the search. */ - searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj); - if (searchPtr == NULL) { + if (!(searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj))) { return TCL_ERROR; } /* * Unhook the search from the list of searches associated with the * variable. */ - hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); - if (searchPtr == Tcl_GetHashValue(hPtr)) { - if (searchPtr->nextPtr) { - Tcl_SetHashValue(hPtr, searchPtr->nextPtr); - } else { - varPtr->flags &= ~VAR_SEARCH_ACTIVE; - Tcl_DeleteHashEntry(hPtr); - } - } else { - for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { - if (prevPtr->nextPtr == searchPtr) { - prevPtr->nextPtr = searchPtr->nextPtr; - break; - } - } - } - Tcl_DecrRefCount(searchPtr->name); - ckfree(searchPtr); + ArrayDone(interp, searchPtr); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -3196,48 +4508,24 @@ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; - Tcl_Obj *arrayNameObj; - int notArray; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); - return TCL_ERROR; - } - arrayNameObj = objv[1]; - - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, arrayNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } - } - - /* - * Check whether we've actually got an array variable. - */ - - notArray = ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)); - Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[!notArray]); + Tcl_Obj *varNameObj, *filterObj; + int exists, filterType; + + if (ArrayArgs(interp, objc, objv, &varNameObj, + &filterObj, &filterType) != TCL_OK) { + return TCL_ERROR; + } + + if (Tcl_ArrayExists(interp, varNameObj, filterObj, &exists, + filterType) != TCL_OK) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[exists]); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -3262,167 +4550,29 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr, *varPtr2; - Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj; - Tcl_Obj **nameObjPtr, *patternObj; - Tcl_HashSearch search; - const char *pattern; - int i, count, result; - - switch (objc) { - case 2: - varNameObj = objv[1]; - patternObj = NULL; - break; - case 3: - varNameObj = objv[1]; - patternObj = objv[2]; - break; - default: - Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?pattern?"); - return TCL_ERROR; - } - - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } - } - - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. If not an array, it's an empty result. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - return TCL_OK; - } - - pattern = (patternObj ? TclGetString(patternObj) : NULL); - - /* - * Store the array names in a new object. - */ - - TclNewObj(nameLstObj); - Tcl_IncrRefCount(nameLstObj); - if ((patternObj != NULL) && TclMatchIsTrivial(pattern)) { - varPtr2 = VarHashFindVar(varPtr->value.tablePtr, patternObj); - if (varPtr2 == NULL) { - goto searchDone; - } - if (TclIsVarUndefined(varPtr2)) { - goto searchDone; - } - result = Tcl_ListObjAppendElement(interp, nameLstObj, - VarHashGetKey(varPtr2)); - if (result != TCL_OK) { - TclDecrRefCount(nameLstObj); - return result; - } - goto searchDone; - } - - for (varPtr2 = VarHashFirstVar(varPtr->value.tablePtr, &search); - varPtr2; varPtr2 = VarHashNextVar(&search)) { - if (TclIsVarUndefined(varPtr2)) { - continue; - } - nameObj = VarHashGetKey(varPtr2); - if (patternObj && !Tcl_StringMatch(TclGetString(nameObj), pattern)) { - continue; /* Element name doesn't match pattern. */ - } - - result = Tcl_ListObjAppendElement(interp, nameLstObj, nameObj); - if (result != TCL_OK) { - TclDecrRefCount(nameLstObj); - return result; - } - } - - /* - * Make sure the Var structure of the array is not removed by a trace - * while we're working. - */ - - searchDone: - if (TclIsVarInHash(varPtr)) { - VarHashRefCount(varPtr)++; - } - - /* - * Get the array values corresponding to each element name. - */ - - TclNewObj(tmpResObj); - result = Tcl_ListObjGetElements(interp, nameLstObj, &count, &nameObjPtr); - if (result != TCL_OK) { - goto errorInArrayGet; - } - - for (i=0 ; i 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?"); - return TCL_ERROR; - } - varNameObj = objv[1]; - patternObj = (objc > 2 ? objv[objc-1] : NULL); - - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } - } - - /* - * Finish parsing the arguments. - */ - - if ((objc == 4) && Tcl_GetIndexFromObj(interp, objv[2], options, "option", - 0, &mode) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. If not an array, the result is empty. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - return TCL_OK; - } - - /* - * Check for the trivial cases where we can use a direct lookup. - */ + Tcl_Obj *varNameObj, *filterObj, *resultObj; + int filterType; + + if (ArrayArgs(interp, objc, objv, &varNameObj, + &filterObj, &filterType) != TCL_OK) { + return TCL_ERROR; + } TclNewObj(resultObj); - if (patternObj) { - pattern = TclGetString(patternObj); - } - if ((mode==OPT_GLOB && patternObj && TclMatchIsTrivial(pattern)) - || (mode==OPT_EXACT)) { - varPtr2 = VarHashFindVar(varPtr->value.tablePtr, patternObj); - if ((varPtr2 != NULL) && !TclIsVarUndefined(varPtr2)) { - /* - * This can't fail; lappending to an empty object always works. - */ - - Tcl_ListObjAppendElement(NULL, resultObj, VarHashGetKey(varPtr2)); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - } - - /* - * Must scan the array to select the elements. - */ - - for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); - varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { - if (TclIsVarUndefined(varPtr2)) { - continue; - } - nameObj = VarHashGetKey(varPtr2); - if (patternObj) { - const char *name = TclGetString(nameObj); - int matched = 0; - - switch ((enum options) mode) { - case OPT_EXACT: - Tcl_Panic("exact matching shouldn't get here"); - case OPT_GLOB: - matched = Tcl_StringMatch(name, pattern); - break; - case OPT_REGEXP: - matched = Tcl_RegExpMatchObj(interp, nameObj, patternObj); - if (matched < 0) { - TclDecrRefCount(resultObj); - return TCL_ERROR; - } - break; - } - if (matched == 0) { - continue; - } - } - - Tcl_ListObjAppendElement(NULL, resultObj, nameObj); - } - Tcl_SetObjResult(interp, resultObj); + Tcl_IncrRefCount(resultObj); + if (Tcl_ArrayNames(interp, varNameObj, filterObj, resultObj, + filterType) != TCL_OK) { + Tcl_DecrRefCount(resultObj); + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, resultObj); + Tcl_DecrRefCount(resultObj); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -3638,40 +4689,16 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; - if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName list"); return TCL_ERROR; } - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, objv[1], NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, objv[1], NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } - } - - return TclArraySet(interp, objv[1], objv[2]); + return Tcl_ArraySet(interp, objv[1], objv[2], 0); } /* *---------------------------------------------------------------------- * @@ -3695,62 +4722,21 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; - Tcl_Obj *varNameObj; - Tcl_HashSearch search; - Var *varPtr2; - int size = 0; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); - return TCL_ERROR; - } - varNameObj = objv[1]; - - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } - } - - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. We can only iterate over the array if it exists... - */ - - if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { - /* - * Must iterate in order to get chance to check for present but - * "undefined" entries. - */ - - for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); - varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { - if (!TclIsVarUndefined(varPtr2)) { - size++; - } - } + Tcl_Obj *varNameObj, *filterObj; + int filterType, size; + + if (ArrayArgs(interp, objc, objv, &varNameObj, + &filterObj, &filterType) != TCL_OK) { + return TCL_ERROR; + } + + if (Tcl_ArraySize(interp, varNameObj, filterObj, &size, + filterType) != TCL_OK) { + return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(size)); return TCL_OK; } @@ -3779,65 +4765,26 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; - Tcl_Obj *varNameObj; - char *stats; + Tcl_Obj *resultObj; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } - varNameObj = objv[1]; - - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } - } - - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); - return TCL_ERROR; - } - - stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr); - if (stats == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "error reading array statistics", -1)); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1)); - ckfree(stats); + + TclNewObj(resultObj); + Tcl_IncrRefCount(resultObj); + if (Tcl_ArrayStatistics(interp, objv[1], resultObj, 0) != TCL_OK) { + Tcl_DecrRefCount(resultObj); + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, resultObj); + Tcl_DecrRefCount(resultObj); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -3862,145 +4809,19 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr, *varPtr2, *protectedVarPtr; - Tcl_Obj *varNameObj, *patternObj, *nameObj; - Tcl_HashSearch search; - const char *pattern; - const int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */ - - switch (objc) { - case 2: - varNameObj = objv[1]; - patternObj = NULL; - break; - case 3: - varNameObj = objv[1]; - patternObj = objv[2]; - break; - default: - Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?pattern?"); - return TCL_ERROR; - } - - /* - * Locate the array variable - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } - } - - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - return TCL_OK; - } - - if (!patternObj) { - /* - * When no pattern is given, just unset the whole array. - */ - - return TclObjUnsetVar2(interp, varNameObj, NULL, 0); - } - - /* - * With a trivial pattern, we can just unset. - */ - - pattern = TclGetString(patternObj); - if (TclMatchIsTrivial(pattern)) { - varPtr2 = VarHashFindVar(varPtr->value.tablePtr, patternObj); - if (!varPtr2 || TclIsVarUndefined(varPtr2)) { - return TCL_OK; - } - return TclPtrUnsetVar(interp, varPtr2, varPtr, varNameObj, patternObj, - unsetFlags, -1); - } - - /* - * Non-trivial case (well, deeply tricky really). We peek inside the hash - * iterator in order to allow us to guarantee that the following element - * in the array will not be scrubbed until we have dealt with it. This - * stops the overall iterator from ending up pointing into deallocated - * memory. [Bug 2939073] - */ - - protectedVarPtr = NULL; - for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); - varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { - /* - * Drop the extra ref immediately. We don't need to free it at this - * point though; we'll be unsetting it if necessary soon. - */ - - if (varPtr2 == protectedVarPtr) { - VarHashRefCount(varPtr2)--; - } - - /* - * Guard the next (peeked) item in the search chain by incrementing - * its refcount. This guarantees that the hash table iterator won't be - * dangling on the next time through the loop. - */ - - if (search.nextEntryPtr != NULL) { - protectedVarPtr = VarHashGetValue(search.nextEntryPtr); - VarHashRefCount(protectedVarPtr)++; - } else { - protectedVarPtr = NULL; - } - - /* - * If the variable is undefined, clean it out as it has been hit by - * something else (i.e., an unset trace). - */ - - if (TclIsVarUndefined(varPtr2)) { - CleanupVar(varPtr2, varPtr); - continue; - } - - nameObj = VarHashGetKey(varPtr2); - if (Tcl_StringMatch(TclGetString(nameObj), pattern) - && TclPtrUnsetVar(interp, varPtr2, varPtr, varNameObj, - nameObj, unsetFlags, -1) != TCL_OK) { - /* - * If we incremented a refcount, we must decrement it here as we - * will not be coming back properly due to the error. - */ - - if (protectedVarPtr) { - VarHashRefCount(protectedVarPtr)--; - CleanupVar(protectedVarPtr, varPtr); - } - return TCL_ERROR; - } - } - return TCL_OK; + Tcl_Obj *varNameObj, *filterObj; + int filterType; + + if (ArrayArgs(interp, objc, objv, &varNameObj, + &filterObj, &filterType) != TCL_OK) { + return TCL_ERROR; + } + + return Tcl_ArrayUnset(interp, varNameObj, filterObj, filterType); } /* *---------------------------------------------------------------------- * @@ -4285,11 +5106,11 @@ return TCL_OK; } if (TclIsVarInHash(linkPtr)) { VarHashRefCount(linkPtr)--; if (TclIsVarUndefined(linkPtr)) { - CleanupVar(linkPtr, NULL); + TclCleanupVar(linkPtr, NULL); } } } TclSetVarLink(varPtr); varPtr->value.linkPtr = otherPtr; @@ -4848,11 +5669,12 @@ } } /* Fallback: do string compares. */ for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL; searchPtr = searchPtr->nextPtr) { - if (strcmp(TclGetString(searchPtr->name), handle) == 0) { + if (searchPtr->name + && strcmp(TclGetString(searchPtr->name), handle) == 0) { return searchPtr; } } } if ((handle[0] != 's') || (handle[1] != '-') @@ -4875,12 +5697,14 @@ /* *---------------------------------------------------------------------- * * DeleteSearches -- * - * This function is called to free up all of the searches associated - * with an array variable. + * This function is called to free up all of the searches associated with + * an array variable. Any searches with the KEEP_ON_ABORT flag set will not + * immediately be freed but will have the SEARCH_ABORTED flag set so they + * will be freed the next time a search operation is performed. * * Results: * None. * * Side effects: @@ -4901,12 +5725,15 @@ if (arrayVarPtr->flags & VAR_SEARCH_ACTIVE) { sPtr = Tcl_FindHashEntry(&iPtr->varSearches, arrayVarPtr); for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL; searchPtr = nextPtr) { nextPtr = searchPtr->nextPtr; - Tcl_DecrRefCount(searchPtr->name); - ckfree(searchPtr); + if (searchPtr->flags & KEEP_ON_ABORT) { + searchPtr->flags |= SEARCH_ABORTED; + } else { + ArraySearchFree(searchPtr); + } } arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE; Tcl_DeleteHashEntry(sPtr); } } ADDED tests/array.test Index: tests/array.test ================================================================== --- /dev/null +++ tests/array.test @@ -0,0 +1,888 @@ +# Commands covered: array +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 2016 Andy Goth +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[lsearch [namespace children] ::tcltest] < 0} { + package require tcltest 2 +} +::tcltest::loadTestedCommands +catch {package require -exact Tcltest [info patchlevel]} +set namespaces [namespace children] +set procs [info procs] +set vars [info vars] + +# test set chapter title +# --------- ----------------------- +# array-1.* subcommand dispatch +# array-2.* common argument parsing +# array-3.* array set +# array-4.* array unset +# array-5.* array statistics +# array-6.* array exists|size|names|get +# array-7.* array anymore|donesearch|nextelement|startsearch + +# test set [array] subcommand arrayName mode and filter +# --------- ------------------ -------------------- --------------- +# array-7.* anymore array required not allowed +# array-7.* donesearch array required not allowed +# array-6.* exists anything optional +# array-6.* get anything optional +# array-6.* names anything optional +# array-7.* nextelement array required not allowed +# array-3.* set array or nonexistent not allowed +# array-6.* size anything optional +# array-7.* startsearch array required optional +# array-5.* statistics array required not allowed +# array-4.* unset anything optional +# array-1.* (unique abbrev) (see above) (see above) +# array-1.* (ambiguous abbrev) (error) (error) +# array-1.* (invalid) (error) (error) + +# oxfordJoin -- +# and -- +# or -- +# Joins a list by commas, a conjunction, or both, using Oxford comma rules, +# matching Tcl's internal algorithm for displaying lists in error messages. +proc oxfordJoin {conjunction list} { + if {[llength $list] > 1} { + lset list end "$conjunction [lindex $list end]" + } + if {[llength $list] < 3} { + join $list " " + } else { + join $list ", " + } +} +interp alias {} and {} oxfordJoin and +interp alias {} or {} oxfordJoin or + +# samples -- +# Produces a list of sample arguments, given a list of parameters. +# Customizations can be applied via $args. +proc samples {params args} { + set map [dict merge { + arrayName a + searchId s-1-a + ?mode? -exact + ?pattern? hello + list {hello world} + } $args] + lmap param $params {dict get $map $param} +} + +# test -- +# Wrapper around [::tcltest::test] with additional features: +# +# - Single-argument block design gives a cleaner visual presentation. +# - All script execution is performed in a new stack frame. +# - Script variables are shared across scripts via a temporary namespace. +# - All definition values (except scripts) are [subst]'ed. +# +# The $def argument is a dict which defines the test. Its possible keys are: +# +# - name | desc +# Test name and description. +# +# - {scalar name} | {array name} +# The name component of the key is the name of a scalar or array variable, and +# the value is the initial scalar value or array dictionary value. These +# variables are shared across the setup, body, and cleanup scripts. +# +# - link +# Uninitialized variables shared across the setup, body, and cleanup scripts. +# +# - setup | body | cleanup +# The scripts are modified to include variable initialization, linkage, and +# finalization and to be executed inside new stack frames. +# +# - constraints | result | output | errorOutput | returnCodes | match +# See tcltest(n) for the purpose of these keys. +proc test {def} { + # Perform uplevel substitutions, and process scalar and array arguments. + set scalars {} + set arrays {} + dict for {key val} $def { + if {$key ni {setup body cleanup}} { + dict set def $key [set val [uplevel [list subst $val]]] + } + if {[llength $key] == 2} { + if {[lindex $key 0] eq "scalar"} { + dict set scalars [lindex $key 1] $val + dict unset def $key + } elseif {[lindex $key 0] eq "array"} { + dict set arrays [lindex $key 1] $val + dict unset def $key + } + } + } + + # Augment scripts with variable initialization, linkage, and finalization. + dict lappend def link {*}[dict keys $scalars] {*}[dict keys $arrays] + if {[llength [dict get $def link]]} { + # Ensure all three scripts exist, even if empty. + foreach key {setup body cleanup} { + dict append def $key + } + + # Build variable initialization, linkage, and finalization snippets. + set initial [list namespace eval ::TestVars [join [list\ + [list variable {*}$scalars]\ + {*}[lmap {var val} $arrays {list variable $var}]\ + {*}[lmap {var val} $arrays {list array set $var $val}]] \n]] + set linkage [join [lmap var [dict get $def link]\ + {list variable ::TestVars::$var}] \n] + set final [list namespace delete ::TestVars] + + # Update scripts. + dict set def setup $initial\n$linkage\n[dict get $def setup] + dict set def body $linkage\n[dict get $def body] + dict set def cleanup $linkage\n[dict get $def cleanup]\n$final + } + dict unset def link + + # Convert scripts to zero-argument lambda invocations. + foreach key {setup body cleanup} { + if {[dict exists $def $key]} { + dict set def $key [list apply [list {} [dict get $def $key]]] + } + } + + # Assemble the Tcltest command. + set command [list ::tcltest::test [dict get $def name] [dict get $def desc]] + dict unset def name + dict unset def desc + foreach key {constraints setup body cleanup result output errorOutput + returnCodes match} { + if {[dict exists $def $key]} { + lappend command -$key [dict get $def $key] + dict unset def $key + } + } + + # Complain if there are any invalid test definition keys. + if {[dict size $def]} { + error "bad test definition key(s): [and [dict keys $def]]" + } + + # Run the Tcltest command. + tailcall {*}$command +} + +# Formal parameters for each array subcommand. +set params { + anymore {arrayName searchId} + donesearch {arrayName searchId} + exists {arrayName ?mode? ?pattern?} + get {arrayName ?mode? ?pattern?} + names {arrayName ?mode? ?pattern?} + nextelement {arrayName searchId} + set {arrayName list} + size {arrayName ?mode? ?pattern?} + startsearch {arrayName ?mode? ?pattern?} + statistics {arrayName} + unset {arrayName ?mode? ?pattern?} +} + +# List of array subcommands. +set commands [lsort [dict keys $params]] + +# Ambiguous and unambiguous abbreviations of array subcommands. +foreach cmd $commands { + for {set i 0} {$i < [string length $cmd] - 1} {incr i} { + set abbrev [string range $cmd 0 $i] + if {$abbrev in $commands + || [llength [lsearch -all $commands $abbrev*]] == 1} { + dict lappend abbrevs $cmd $abbrev + } else { + dict set ambig $abbrev {} + } + } +} +set ambig [lsort [dict keys $ambig]] + +# List of valid array filter mode options. +set modes [lsort {-exact -glob -regexp}] + +######################## array-1.*: subcommand dispatch ######################## +test { + name array-1.1 + desc {no subcommand} + body {array} + returnCodes error + result {wrong # args: should be "array subcommand ?arg ...?"} +} +test { + name array-1.2 + desc {empty subcommand} + body {array {}} + returnCodes error + result {unknown or ambiguous subcommand "": must be [or $commands]} +} +test { + name array-1.3 + desc {invalid subcommand} + body {array gorp} + returnCodes error + result {unknown or ambiguous subcommand "gorp": must be [or $commands]} +} +foreach cmd $ambig { + test { + name array-1.4.$cmd + desc {ambiguous subcommand: \[array $cmd\]} + {scalar cmd} $cmd + body {array $cmd} + returnCodes error + result {unknown or ambiguous subcommand "$cmd": must be [or $commands]} + } +} +foreach cmd $commands { + test { + name array-1.5.$cmd + desc {formal parameter lists: \[array $cmd\]} + {scalar cmd} $cmd + body {array $cmd} + returnCodes error + result {wrong # args: should be "array $cmd [dict get $params $cmd]"} + } +} + +###################### array-2.*: common argument parsing ###################### +foreach {cmd code resultPattern} { + anymore error "\"%VAR%\" %MSG%" + donesearch error "\"%VAR%\" %MSG%" + exists ok 0 + get ok {} + names ok {} + nextelement error "\"%VAR%\" %MSG%" + set error "can't set \"%VAR%%ELEM%\": %MSG%" + size ok 0 + startsearch error "\"%VAR%\" %MSG%" + statistics error "\"%VAR%\" %MSG%" + unset ok {} +} { + test { + name array-2.1.$cmd + desc {too many arguments: \[array $cmd\]} + {scalar cmd} $cmd + {scalar args} {[lmap param [dict get $params $cmd] {samples $param}]} + body {array $cmd {*}$args extra} + returnCodes error + result {wrong # args: should be "array $cmd [dict get $params $cmd]"} + } + if {"?mode?" in [dict get $params $cmd]} { + test { + name array-2.2.$cmd + desc {ambiguous mode: \[array $cmd\]"} + {scalar cmd} $cmd + {array a} {} + body {array $cmd a {} {}} + returnCodes error + result {ambiguous option "": must be [or $modes]} + } + test { + name array-2.3.$cmd + desc {invalid mode: \[array $cmd\]} + {scalar cmd} $cmd + {array a} {} + body {array $cmd a INVALID {}} + returnCodes error + result {bad option "INVALID": must be [or $modes]} + } + test { + name array-2.4.$cmd + desc {invalid regexp: \[array $cmd\]} + {scalar cmd} $cmd + {array a} {e 1} + body {array $cmd a -regexp *} + returnCodes error + result {couldn't compile regular expression pattern:\ + quantifier operand invalid} + } + } + test { + name array-2.5.$cmd + desc {array trace error during variable lookup: \[array $cmd\]} + {scalar cmd} $cmd + {scalar args} {[lmap param [dict get $params $cmd] {samples $param}]} + link a + setup {trace add variable a array {apply {{args} {error $args}}}} + body {array $cmd {*}$args} + returnCodes error + result {can't trace array "a": a {} array} + } + if {$cmd eq "set"} { + set nonArray "variable isn't array" + set nonNamespace "parent namespace doesn't exist" + } else { + set nonArray "isn't an array" + set nonNamespace "isn't an array" + } + foreach { + desc skip setup + name msg var elem extra + } { + "nonexistent array" set {} + array-2.6 nonArray a {} {} + + "element of proc-slot-only array" set {} + array-2.7 nonArray a {} {set a(hello) 123} + + "scalar variable" {} {{scalar a} {}} + array-2.8 nonArray a (hello) {} + + "element of empty array" {} {{array a} {}} + array-2.9 nonArray a(x) {} {} + + "element of nonexistent array" {} {} + array-2.10 nonArray a(x) {} {} + + "element of scalar variable" {} {{scalar a} {}} + array-2.11 nonArray a(x) {} {} + + "existing element of array" {} {{scalar a} {x 123}} + array-2.12 nonArray a(x) {} {} + + "nonexistent element of array" {} {{array a} {}} + array-2.13 nonArray a(x) {} {} + + "bad namespace" {} {} + array-2.14 nonNamespace ::X::a {} {} + } { + if {$cmd ni $skip} { + set map [list %VAR% $var %MSG% [set $msg] %ELEM% $elem] + test [string map [list %SETUP% $setup %EXTRA% $extra] { + name $name.$cmd + desc {$desc: \[array $cmd\]} + {scalar cmd} $cmd + {scalar args} {[samples [dict get $params $cmd] arrayName $var]} + %SETUP% + body {set result [array $cmd {*}$args]; %EXTRA%; return $result} + returnCodes $code + result {[string map $map $resultPattern]} + }] + } + } +} + +############################# array-3.*: array set ############################# +test { + name array-3.1 + desc {empty} + body {array set a {}; list [array exists a] [array get a]} + result {1 {}} +} +test { + name array-3.2 + desc {one array element} + body {array set a {e 1}; array get a} + result {e 1} +} +test { + name array-3.3 + desc {missing value} + body {array set a e} + returnCodes error + result {list must have an even number of elements} +} +test { + name array-3.4 + desc {duplicate key} + body {array set a {e 0 e 1}; array get a} + result {e 1} +} +test { + name array-3.5 + desc {invalid list} + body {array set a \{\}x} + returnCodes error + result {list element in braces followed by "x" instead of space} +} +test { + name array-3.6 + desc {invalid list part 2} + body {array set a \"\"x} + returnCodes error + result {list element in quotes followed by "x" instead of space} +} +test { + name array-3.7 + desc {invalid list part 3} + body {array set a \{} + returnCodes error + result {unmatched open brace in list} +} +test { + name array-3.8 + desc {invalid list part 4} + body {array set a \"} + returnCodes error + result {unmatched open quote in list} +} +test { + name array-3.9 + desc {hash order} + body {array set a {f 2 e 1}; array get a} + result {e 1 f 2} +} +test { + name array-3.10 + desc {adding elements} + body {array set a {f 2}; array set a {e 1}; array get a} + result {e 1 f 2} +} +test { + name array-3.11 + desc {adding elements, hash order} + body {array set a {e 1}; array set a {f 2}; array get a} + result {e 1 f 2} +} +test { + name array-3.12 + desc {replacing elements} + body {array set a {e 1}; array set a {e 2}; array get a} + result {e 2} +} +test { + name array-3.13 + desc {adding and replacing elements} + body {array set a {e 1}; array set a {f 3 e 2}; array get a} + result {e 2 f 3} +} +test { + name array-3.14 + desc {former scalar} + {scalar a} xxx + body {unset a; array set a {e 1}; array get a} + result {e 1} +} +test { + name array-3.15 + desc {weird names} + body {array set a {{ a b } 1 ) 2 ( 3 )( 4 () 5 {} 6}; array get a} + result {{} 6 ( 3 () 5 )( 4 ) 2 { a b } 1} +} + +############################ array-4.*: array unset ############################ +test { + name array-4.1 + desc {unset empty array} + {array a} {} + body {array unset a; info exists a} + result 0 +} +test { + name array-4.2 + desc {unset non-empty array} + {array a} {e 1} + body {array unset a; info exists a} + result 0 +} +test { + name array-4.3 + desc {unset scalar} + {scalar a} x + body {array unset a; return $a} + result x +} +test { + name array-4.4 + desc {unset all elements of empty array} + {array a} {} + body {array unset a *; list [info exists a] [array size a]} + result {1 0} +} +test { + name array-4.5 + desc {unset all elements of non-empty array} + {array a} {e 1} + body {array unset a *; list [info exists a] [array size a]} + result {1 0} +} +test { + name array-4.6 + desc {unset all elements of scalar array} + {scalar a} x + body {array unset a *; return $a} + result x +} +test { + name array-4.7 + desc {unset single existing element using -exact} + {array a} {f 2 e 1} + body {array unset a -exact e; array get a} + result {f 2} +} +test { + name array-4.8 + desc {unset single nonexistent element using -exact} + {array a} {f 2 e 1} + body {array unset a -exact d; array get a} + result {e 1 f 2} +} +test { + name array-4.9 + desc {unset single existing element using default mode} + {array a} {f 2 e 1} + body {array unset a e; array get a} + result {f 2} +} +test { + name array-4.10 + desc {unset single nonexistent element using default mode} + {array a} {f 2 e 1} + body {array unset a d; array get a} + result {e 1 f 2} +} +test { + name array-4.11 + desc {unset single existing element using -glob} + {array a} {f 2 e 1} + body {array unset a -glob {[e]}; array get a} + result {f 2} +} +test { + name array-4.12 + desc {unset single nonexistent element using -glob} + {array a} {f 2 e 1} + body {array unset a -glob {[d]}; array get a} + result {e 1 f 2} +} +test { + name array-4.13 + desc {unset single existing element using -regexp} + {array a} {f 2 e 1} + body {array unset a -regexp {^[e]}; array get a} + result {f 2} +} +test { + name array-4.14 + desc {unset single nonexistent element using -regexp} + {array a} {f 2 e 1} + body {array unset a -regexp {^[d]}; array get a} + result {e 1 f 2} +} +test { + name array-4.15 + desc {confirm unset -exact does not match substrings} + {array a} {abc 1} + body {array unset a -exact b; array get a} + result {abc 1} +} +test { + name array-4.16 + desc {confirm unset -glob does not match substrings} + {array a} {abc 1} + body {array unset a -glob b; array get a} + result {abc 1} +} +test { + name array-4.17 + desc {confirm unset -regexp does match substrings} + {array a} {abc 1} + body {array unset a -regexp b; array get a} + result {} +} + +######################### array-5.*: array statistics ########################## +# Note: array-5.3 expected results obtained from Tcl version 8.5.7 +test { + name array-5.1 + desc {empty array} + {array a} {} + body {array statistics a} + result +{0 entries in table, 4 buckets +number of buckets with 0 entries: 4 +number of buckets with 1 entries: 0 +number of buckets with 2 entries: 0 +number of buckets with 3 entries: 0 +number of buckets with 4 entries: 0 +number of buckets with 5 entries: 0 +number of buckets with 6 entries: 0 +number of buckets with 7 entries: 0 +number of buckets with 8 entries: 0 +number of buckets with 9 entries: 0 +number of buckets with 10 or more entries: 0 +average search distance for entry: 0.0} +} +test { + name array-5.2 + desc {single-element array} + {array a} {e 1} + body {array statistics a} + result +{1 entries in table, 4 buckets +number of buckets with 0 entries: 3 +number of buckets with 1 entries: 1 +number of buckets with 2 entries: 0 +number of buckets with 3 entries: 0 +number of buckets with 4 entries: 0 +number of buckets with 5 entries: 0 +number of buckets with 6 entries: 0 +number of buckets with 7 entries: 0 +number of buckets with 8 entries: 0 +number of buckets with 9 entries: 0 +number of buckets with 10 or more entries: 0 +average search distance for entry: 1.0} +} +test { + name array-5.3 + desc {thousand-element array} + link a + setup {for {set i 0} {$i < 1000} {incr i} {set a($i) $i}} + body {array statistics a} + result +{1000 entries in table, 1024 buckets +number of buckets with 0 entries: 285 +number of buckets with 1 entries: 520 +number of buckets with 2 entries: 180 +number of buckets with 3 entries: 36 +number of buckets with 4 entries: 3 +number of buckets with 5 entries: 0 +number of buckets with 6 entries: 0 +number of buckets with 7 entries: 0 +number of buckets with 8 entries: 0 +number of buckets with 9 entries: 0 +number of buckets with 10 or more entries: 0 +average search distance for entry: 1.3} +} +test { + name array-5.4 + desc {collision attack} + link a + setup { + for {set i 16} {$i < 29} {incr i} { + set a([binary format cc $i [expr {-$i * 9}]]) $i + } + } + body {array statistics a} + result +{13 entries in table, 16 buckets +number of buckets with 0 entries: 15 +number of buckets with 1 entries: 0 +number of buckets with 2 entries: 0 +number of buckets with 3 entries: 0 +number of buckets with 4 entries: 0 +number of buckets with 5 entries: 0 +number of buckets with 6 entries: 0 +number of buckets with 7 entries: 0 +number of buckets with 8 entries: 0 +number of buckets with 9 entries: 0 +number of buckets with 10 or more entries: 1 +average search distance for entry: 7.0} +} + +################### array-6.*: array exists|size|names|get ##################### +foreach { + desc + name dict args exists size names get +} { + "empty array" + array-6.1 {} {} 1 0 {} {} + + "non-empty array" + array-6.2 {e 1} {} 1 1 {e} {e 1} + + "nonexistent element using default mode" + array-6.3 {e 1} {[d]} 0 0 {} {} + + "existing element using default mode" + array-6.4 {e 1} {[e]} 1 1 {e} {e 1} + + "multiple elements using default mode" + array-6.5 {e 1 f 2} {[ef]} 1 2 {e f} {e 1 f 2} + + "nonexistent element using -glob" + array-6.6 {e 1} {-glob [d]} 0 0 {} {} + + "existing element using -glob" + array-6.7 {e 1} {-glob [e]} 1 1 {e} {e 1} + + "multiple elements using -glob" + array-6.8 {e 1 f 2} {-glob [ef]} 1 2 {e f} {e 1 f 2} + + "nonexistent element using -exact" + array-6.9 {e 1} {-exact d} 0 0 {} {} + + "existing element using -exact" + array-6.10 {e 1} {-exact e} 1 1 {e} {e 1} + + "nonexistent element using -regexp" + array-6.11 {e 1} {-regexp ^[d]} 0 0 {} {} + + "existing element using -regexp" + array-6.12 {e 1} {-regexp ^[e]} 1 1 {e} {e 1} + + "multiple elements using -regexp" + array-6.13 {e 1 f 2} {-regexp ^[ef]} 1 2 {e f} {e 1 f 2} +} { + foreach cmd {exists size names get} { + test [string map [list %RESULT% [set $cmd]] { + name $name.$cmd + desc {$desc: \[array $cmd\]} + {scalar cmd} $cmd + {scalar args} $args + {array a} $dict + body {array $cmd a {*}$args} + result {%RESULT%} + }] + } +} +foreach { + cmd small large +} { + exists 1 1 + size 1 2 + names {e} {e f} + get {e 1} {e 1 f 2} +} { + test { + name array-6.14.$cmd + desc {increasing array size: \[array $cmd\]} + {scalar cmd} $cmd + {array a} {e 1} + body {list [array $cmd a][set a(f) 2; list] [array $cmd a]} + result {[list $small $large]} + } + test { + name array-6.15.$cmd + desc {decreasing array size: \[array $cmd\]} + {scalar cmd} $cmd + {array a} {e 1 f 2} + body {list [array $cmd a][unset a(f)] [array $cmd a]} + result {[list $large $small]} + } +} + +######### array-7.*: array anymore|donesearch|nextelement|startsearch ########## +foreach cmd {anymore donesearch nextelement} { + test { + name array-7.1.$cmd + desc {nonexistent search token} + {scalar cmd} $cmd + {array a} {} + body {array $cmd a s-1-a} + returnCodes error + result {couldn't find search "s-1-a"} + } +} +foreach { + desc + name dict args result +} { + "no filter, empty array" + array-7.2 {} {} {} + + "no filter, single element" + array-7.3 {e 1} {} {e} + + "no filter, two elements" + array-7.4 {f 2 e 1} {} {e f} + + "default filter, matches nothing" + array-7.5 {f 2 e 1} {[g]} {} + + "default filter, matches one item" + array-7.6 {f 2 e 1} {[f]} {f} + + "default filter, matches two items" + array-7.7 {f 2 e 1} {[ef]} {e f} + + "-glob filter, matches nothing" + array-7.8 {f 2 e 1} {-glob [g]} {} + + "-glob filter, matches one item" + array-7.9 {f 2 e 1} {-glob [f]} {f} + + "-glob filter, matches two items" + array-7.10 {f 2 e 1} {-glob [ef]} {e f} + + "-exact filter, matches nothing" + array-7.11 {f 2 e 1} {-exact g} {} + + "-exact filter, matches one item" + array-7.12 {f 2 e 1} {-exact f} {f} + + "-regexp filter, matches nothing" + array-7.13 {f 2 e 1} {-regexp ^[g]} {} + + "-regexp filter, matches one item" + array-7.14 {f 2 e 1} {-regexp ^[f]} {f} + + "-regexp filter, matches two items" + array-7.15 {f 2 e 1} {-regexp ^[ef]} {e f} +} { + test { + name $name + desc $desc + {scalar args} $args + {array a} $dict + body { + set result {} + set s [array startsearch a {*}$args] + while {[array anymore a $s]} { + lappend result [array nextelement a $s] + } + array donesearch a $s + return $result + } + result $result + } +} +test { + name array-7.16 + desc {unset visited element during search, bug 46a2410650, s/a var-13.2} + {array a} {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66} + body { + set s [array startsearch a] + unset a([array nextelement a $s]) + array anymore a $s + } + returnCodes error + result {couldn't find search "s-1-a"} +} +test { + name array-7.17 + desc {unset future element during search, bug 46a2410650, s/a var-13.3} + {array a} {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66} + body { + set result {} + set s [array startsearch a] + unset a(ee) + array anymore a $s + } + returnCodes error + result {couldn't find search "s-1-a"} +} + +# Cleanup. +foreach namespace [namespace children] { + if {$namespace ni $namespaces} { + namespace delete $namespace + } +} +foreach proc [info procs] { + if {$proc ni $procs} { + rename $proc {} + } +} +foreach var [info vars] { + if {$var ne "vars" && $var ni $vars} { + unset $var + } +} +unset -nocomplain var vars +::tcltest::cleanupTests +return + +# vim: set sts=4 sw=4 tw=80 et ft=tcl: +# Local Variables: +# mode: tcl +# End: Index: tests/set-old.test ================================================================== --- tests/set-old.test +++ tests/set-old.test @@ -367,11 +367,11 @@ } list [catch {foo 1} msg] $msg } {1 {"a" isn't an array}} test set-old-8.11 {array command, exists option} { list [catch {array exists a b} msg] $msg -} {1 {wrong # args: should be "array exists arrayName"}} +} {0 0} test set-old-8.12 {array command, exists option} { catch {unset a} array exists a } {0} test set-old-8.13 {array command, exists option} { @@ -388,14 +388,14 @@ } list [catch {foo 1} msg] $msg } {0 0} test set-old-8.15 {array command, get option} { list [catch {array get} msg] $msg -} {1 {wrong # args: should be "array get arrayName ?pattern?"}} +} {1 {wrong # args: should be "array get arrayName ?mode? ?pattern?"}} test set-old-8.16 {array command, get option} { list [catch {array get a b c} msg] $msg -} {1 {wrong # args: should be "array get arrayName ?pattern?"}} +} {1 {bad option "b": must be -exact, -glob, or -regexp}} test set-old-8.17 {array command, get option} { catch {unset a} array get a } {} test set-old-8.18 {array command, get option} { @@ -558,11 +558,11 @@ catch {unset a} array size a } {0} test set-old-8.40 {array command, size option} { list [catch {array size a 4} msg] $msg -} {1 {wrong # args: should be "array size arrayName"}} +} {0 0} test set-old-8.41 {array command, size option} { catch {unset a} array size a } {0} test set-old-8.42 {array command, size option} { @@ -590,12 +590,13 @@ set a(x) 123 } list [catch {foo 1} msg] $msg } {0 0} test set-old-8.46 {array command, startsearch option} { + catch {unset a} list [catch {array startsearch a b} msg] $msg -} {1 {wrong # args: should be "array startsearch arrayName"}} +} {1 {"a" isn't an array}} test set-old-8.47 {array command, startsearch option} { catch {unset a} list [catch {array startsearch a} msg] $msg } {1 {"a" isn't an array}} test set-old-8.48 {array command, startsearch option, array doesn't exist yet but has compiler-allocated procedure slot} { @@ -807,14 +808,16 @@ lsort [list [array next a $x] [array next a $x]] } {{} a} test set-old-10.1 {array enumeration errors} { list [catch {array start} msg] $msg -} {1 {wrong # args: should be "array startsearch arrayName"}} -test set-old-10.2 {array enumeration errors} { - list [catch {array start a b} msg] $msg -} {1 {wrong # args: should be "array startsearch arrayName"}} +} {1 {wrong # args: should be "array startsearch arrayName ?mode? ?pattern?"}} +test set-old-10.2 {array command, startsearch option} { + # Note: appears to be almost identical to set-old-8.47 + catch {unset a} + list [catch {array start a} msg] $msg +} {1 {"a" isn't an array}} test set-old-10.3 {array enumeration errors} { catch {unset a} list [catch {array start a} msg] $msg } {1 {"a" isn't an array}} test set-old-10.4 {array enumeration errors} { Index: tests/var.test ================================================================== --- tests/var.test +++ tests/var.test @@ -744,11 +744,11 @@ test var-11.3 {array unset errors} -setup { catch {unset a} } -returnCodes error -body { array set a { 1,1 a 1,2 b } array unset a pattern too -} -result {wrong # args: should be "array unset arrayName ?pattern?"} +} -result {bad option "pattern": must be -exact, -glob, or -regexp} test var-12.1 {TclFindCompiledLocals, {} array name} { namespace eval n { proc p {} { variable {} @@ -775,10 +775,28 @@ trace variable t(1) u foo unset t } set x "If you see this, it worked" } -result "If you see this, it worked" + +test var-13.2 {unset array with search, bug 46a2410650} -body { + apply {{} { + array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66} + set s [array startsearch a] + unset a([array nextelement a $s]) + array nextelement a $s + }} +} -returnCodes error -result {couldn't find search "s-1-a"} + +test var-13.3 {unset array with search, SIGSEGV, bug 46a2410650} -body { + apply {{} { + array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66} + set s [array startsearch a] + unset a(ff) + array nextelement a $s + }} +} -returnCodes error -result {couldn't find search "s-1-a"} test var-14.1 {array names syntax} -body { array names foo bar baz snafu } -returnCodes 1 -match glob -result * test var-14.2 {array names -glob} -body {