From 677e85edc90d09942a06fc0f7ee0885669caa5e0 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 5 Apr 2003 01:03:17 +0000 Subject: The bulk of the TIP#111 implementation. Still need to finish plumbing this into the rest of the core, but that won't take long... --- ChangeLog | 7 + doc/DictObj.3 | 184 ++++ doc/dict.n | 183 ++++ generic/tclDictObj.c | 2558 ++++++++++++++++++++++++++++++++++++++++++++++++++ tests/dict.test | 706 ++++++++++++++ 5 files changed, 3638 insertions(+) create mode 100644 doc/DictObj.3 create mode 100644 doc/dict.n create mode 100644 generic/tclDictObj.c create mode 100644 tests/dict.test diff --git a/ChangeLog b/ChangeLog index 3ac0fb5..76f59d1 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2003-04-05 Donal K. Fellows + + * doc/DictObj.3: New files containing dictionary + * doc/dict.n: implementation, documentation and tests + * generic/tclDictObj.c: as mandated by TIP #111. + * tests/dict.test: + 2003-04-03 Mo DeJong * unix/configure: diff --git a/doc/DictObj.3 b/doc/DictObj.3 new file mode 100644 index 0000000..24f41dd --- /dev/null +++ b/doc/DictObj.3 @@ -0,0 +1,184 @@ +'\" +'\" Copyright (c) 2003 Donal K. Fellows +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" RCS: @(#) $Id: DictObj.3,v 1.1 2003/04/05 01:03:20 dkf Exp $ +'\" +.so man.macros +.TH Tcl_DictObj 3 8.5 Tcl "Tcl Library Procedures" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_NewDictObj, Tcl_DictObjPut, Tcl_DictObjGet, Tcl_DictObjRemove, Tcl_DictObjSize, Tcl_DictObjFirst, Tcl_DictObjNext, Tcl_DictObjDone, Tcl_DictObjPutKeyList, Tcl_DictObjRemoveKeyList \- manipulate Tcl objects as dictionaries +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tcl_Obj * +\fBTcl_NewDictObj\fR() +.sp +int +\fBTcl_DictObjGet\fR(\fIinterp, dictPtr, keyPtr, valuePtrPtr\fR) +.sp +int +\fBTcl_DictObjPut\fR(\fIinterp, dictPtr, keyPtr, valuePtr\fR) +.sp +int +\fBTcl_DictObjRemove\fR(\fIinterp, dictPtr, keyPtr\fR) +.sp +int +\fBTcl_DictObjSize\fR(\fIinterp, dictPtr, sizePtr\fR) +.sp +int +\fBTcl_DictObjFirst\fR(\fIinterp, dictPtr, searchPtr, keyPtrPtr, valuePtrPtr, donePtr\fR) +.sp +void +\fBTcl_DictObjNext\fR(\fIsearchPtr, keyPtrPtr, valuePtrPtr, donePtr\fR) +.sp +void +\fBTcl_DictObjDone\fR(\fIsearchPtr\fR) +.sp +int +\fBTcl_DictObjPutKeyList\fR(\fIinterp, dictPtr, keyc, keyv, valuePtr\fR) +.sp +int +\fBTcl_DictObjRemoveKeyList\fR(\fIinterp, dictPtr, keyc, keyv\fR) +.SH ARGUMENTS +.AS Tcl_DictSearch "**valuePtrPtr" out +.AP Tcl_Interp *interp in +If an error occurs while converting an object to be a dictionary object, +an error message is left in the interpreter's result object +unless \fIinterp\fR is NULL. +.AP Tcl_Obj *dictPtr in/out +Points to the dictionary object to be manipulated. +If \fIdictPtr\fR does not already point to a dictionary object, +an attempt will be made to convert it to one. +.AP Tcl_Obj *keyPtr in +Points to the key for the key/value pair being manipulated within the +dictionary object. +.AP Tcl_Obj *valuePtr in +Points to the value for the key/value pair being manipulate within the +dictionary object (or sub-object, in the case of +\fBTcl_DictObjPutKeyList\fR.) +.AP Tcl_Obj **valuePtrPtr out +Points to a variable that will have the value from a key/value pair +placed within it. For \fBTcl_DictObjFirst\fR and +\fBTcl_DictObjNext\fR, this may be NULL to indicate that the caller is +not interested in the value. +.AP Tcl_Obj **valuePtrPtr out +Points to a variable that will have the key from a key/value pair +placed within it. May be NULL to indicate that the caller is not +interested in the key. +.AP int *sizePtr out +Points to a variable that will have the number of key/value pairs +contained within the dictionary placed within it. +.AP Tcl_DictSearch *searchPtr in/out +Pointer to record to use to keep track of progress in enumerating all +key/value pairs in a dictionary. The contents of the record will be +initialised by the call to \fBTcl_DictObjFirst\fR. If the enumerating +is to be terminated before all values in the dictionary have been +returned, the search record \fImust\fR be passed to +\fBTcl_DictObjDone\fR to enable the internal locks to be released. +.AP int *donePtr out +Points to a variable that will have a non-zero value written into it +when the enumeration of the key/value pairs in a dictionary has +completed, and a zero otherwise. +.AP int keyc in +Indicates the number of keys that will be supplied in the \fIkeyv\fR +array. +.AP "Tcl_Obj *CONST" *keyv in +Array of \fIkeyc\fR pointers to objects that +\fBTcl_DictObjPutKeyList\fR and \fBTcl_DictObjRemoveKeyList\fR will +use to locate the key/value pair to manipulate within the +sub-dictionaries of the main dictionary object passed to them. +.BE + +.SH DESCRIPTION +.PP +Tcl dict objects have an internal representation that supports +efficient mapping from keys to values. +The procedures described in this man page are used to +create, modify, index, and iterate over Tcl dict objects from C code. +.PP +\fBTcl_NewDictObj\fR creates a new, empty dictionary object. The +string representation of the object will be invalid, and the reference +count of the object will be zero. +.PP +\fBTcl_DictObjGet\fR looks up the given key within the given +dictionary and writes a pointer to the value associated with that key +into the variable pointed to by \fIvaluePtrPtr\fR, or a NULL if the +key has no mapping within the dictionary. The result of this +procedure is TCL_OK, or TCL_ERROR if the \fIdictPtr\fR cannot be +converted to a dictionary. +.PP +\fBTcl_DictObjPut\fR updates the given dictionary so that the given +key maps to the given value; any key may exist at most once in any +particular dictionary. The dictionary must not be shared, but the key +and value may be. This procedure may increase the reference count of +both key and value if it proves necessary to store them. Neither key +nor value should be NULL. The result of this procedure is TCL_OK, or +TCL_ERROR if the \fIdictPtr\fR cannot be converted to a dictionary. +.PP +\fBTcl_DictObjRemove\fR updates the given dictionary so that the given +key has no mapping to any value. The dictionary must not be shared, +but the key may be. The key actually stored in the dictionary will +have its reference count decremented if it was present. It is not an +error if the key did not previously exist. The result of this +procedure is TCL_OK, or TCL_ERROR if the \fIdictPtr\fR cannot be +converted to a dictionary. +.PP +\fBTcl_DictObjSize\fR updates the given variable with the number of +key/value pairs currently in the given dictionary.The result of this +procedure is TCL_OK, or TCL_ERROR if the \fIdictPtr\fR cannot be +converted to a dictionary. +.PP +\fBTcl_DictObjFirst\fR commences an iteration across all the key/value +pairs in the given dictionary, placing the key and value in the +variables pointed to by the \fIkeyPtrPtr\fR and \fIvaluePtrPtr\fR +arguments (which may be NULL to indicate that the caller is +uninterested in they key or variable respectively.) The next +key/value pair in the dictionary may be retrieved with +\fBTcl_DictObjNext\fR. Concurrent updates of the dictionary's +internal representation will not modify the iteration processing +unless the dictionary is unshared, when this will trigger premature +termination of the iteration instead (which Tcl scripts cannot trigger +via the \fBdict\fR command.) The \fIsearchPtr\fR argument points to a +piece of context that is used to identify which particular iteration +is being performed, and is initialised by the call to +\fBTcl_DictObjFirst\fR. The \fIdonePtr\fR argument points to a +variable that is updated to be zero of there are further key/value +pairs to be iterated over, or non-zero if the iteration is complete. +The order of iteration is implementation-defined. If the +\fIdictPtr\fR argument cannot be converted to a dictionary, +\fBTcl_DictObjFirst\fR returns TCL_ERROR and the iteration is not +commenced, and otherwise it returns TCL_OK. +.PP +If the last call to \fBTcl_DictObjFirst\fR or \fBTcl_DictObjNext\fR +(for a particular \fIsearchPtr\fR) set the variable indicated by the +\fIdonePtr\fR argument to zero but no further key/value pairs are +desired from that particular iteration, the \fIsearchPtr\fR argument +must be passed to \fBTcl_DictObjDone\fR to release any internal locks +held by the searching process. +.PP +The procedures \fBTcl_DictObjPutKeyList\fR and +\fBTcl_DictObjRemoveKeyList\fR are the close analogues of +\fBTcl_DictObjPut\fR and \fBTcl_DictObjRemove\fR respectively, except +that instead of working with a single dictionary, they are designed to +operate on a nested tree of dictionaries, with inner dictionaries +stored as values inside outer dictionaries. The \fIkeyc\fR and +\fIkeyv\fR arguments specify a list of keys (with outermost keys +first) that acts as a path to the key/value pair to be affected. Note +that there is no corresponding operation for reading a value for a +path as this is easy to construct from repeated use of +\fBTcl_DictObjGet\fR. + +'\" TODO: Example of using Tcl_DictObj{First,Next,Done} + +.SH "SEE ALSO" +Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_InitObjHashTable + +.SH KEYWORDS +dict, dict object, dictionary, hash table, iteration, object + diff --git a/doc/dict.n b/doc/dict.n new file mode 100644 index 0000000..70c4db3 --- /dev/null +++ b/doc/dict.n @@ -0,0 +1,183 @@ +'\" +'\" Copyright (c) 2003 Donal K. Fellows +'\" +'\" See the file "license.terms" for information on usage and + \" redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" RCS: @(#) $Id: dict.n,v 1.1 2003/04/05 01:03:20 dkf Exp $ +'\" +.so man.macros +.TH dict n 8.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +dict \- Manipulate dictionaries. +.SH SYNOPSIS +\fBdict \fIoption arg \fR?\fIarg ...\fR? +.BE + +.SH DESCRIPTION +.PP +Performs one of several operations on dictionary values or variables +containing dictionary values, depending on \fIoption\fR. The legal +\fIoption\fRs (which may be abbreviated) are: +.TP +\fBdict append \fIdictionaryVariable key \fR?\fIstring ...\fR? +This appends the given string (or strings) to the value that the given +key maps to in the dictionary value contained in the given variable, +writing the resulting dictionary value back to that variable. +Non-existent keys are treated as if they map to an empty string. +.TP +\fBdict create \fR?\fIkey value ...\fR? +Create a new dictionary that contains each of the key/value mappings +listed as arguments (keys and values alternating, with each key being +followed by its associated value.) +.TP +\fBdict exists \fIdictionaryValue key \fR?\fIkey ...\fR? +This returns a boolean value indicating whether the given key (or path +of keys through a set of nested dictionaries) exists in the given +dictionary value. This returns a true value exactly when \fBdict +get\fR on that path will succeed. +.TP +\fBdict filter \fIdictionaryValue filterType arg \fR?\fIarg ...\fR? +This takes a dictionary value and returns a new dictionary that +contains just those key/value pairs that match the specified filter +type (which may be abbreviated.) Supported filter types are: +.RS +.TP +\fBdict filter \fIdictionaryValue \fBkey \fIglobPattern\fR +The key rule only matches those key/value pairs whose keys match the +given pattern (in the style of \fBstring match\fR.) +.TP +\fBdict filter \fIdictionaryValue \fBscript {\fIkeyVar valueVar\fB} \fIscript\fR +The script rule tests for matching by assigning the key to the +\fIkeyVar\fR and the value to the \fIvalueVar\fR, and then evaluating +the given script which should return a boolean value (with the +key/value pair only being included in the result of the \fBdict +filter\fR when a true value is returned.) Note that the first +argument after the rule selection word is a two-element list. If the +\fIscript\fR returns with a condition of TCL_BREAK, no further +key/value pairs are considered for inclusion in the resulting +dictionary, and a condition of TCL_CONTINUE is equivalent to a false +result. +.TP +\fBdict filter \fIdictionaryValue \fBvalue \fIglobPattern\fR +The value rule only matches those key/value pairs whose values match +the given pattern (in the style of \fBstring match\fR.) +.RE +.TP +\fBdict for {\fIkeyVar valueVar\fB} \fIdictionaryValue body\fR +This command takes three arguments, the first a two-element list of +variable names (for the key and value respectively of each mapping in +the dictionary), the second the dictionary value to iterate across, +and the third a script to be evaluated for each mapping with the key +and value variables set appropriately (in the manner of \fBforeach\fR.) +The result of the command is an empty string. If any evaluation of the +body generates a TCL_BREAK result, no further pairs from the +dictionary will be iterated over and the \fBdict for\fR command will +terminate successfully immediately. If any evaluation of the body +generates a TCL_CONTINUE result, this shall be treated exactly like a +normal TCL_OK result. The order of iteration is undefined. +.TP +\fBdict get \fIdictionaryValue \fR?\fIkey ...\fR? +Given a dictionary value (first argument) and a key (second argument), +this will retrieve the value for that key. Where several keys are +supplied, the behaviour of the command shall be as if the result of +\fBdict get $dictVal $key\fR was passed as the first argument to +\fBdict get\fR with the remaining arguments as second (and possibly +subsequent) arguments. This facilitates lookups in nested +dictionaries. For example, the following two commands are equivalent: +.RS +.CS +dict get $dict foo bar spong +dict get [dict get [dict get $dict foo] bar] spong +.CE +If no keys are provided, dict would return a list containing pairs of +elements in a manner similar to \fBarray get\fR. That is, the first +element of each pair would be the key and the second element would be +the value for that key. + +It is an error to attempt to retrieve a value for a key that is not +present in the dictionary. +.RE +.TP +\fBdict incr \fIdictionaryVariable key \fR?\fIincrement\fR? +This adds the given increment value (an integer that defaults to 1 if +not specified) to the value that the given key maps to in the +dictionary value contained in the given variable, writing the +resulting dictionary value back to that variable. Non-existent keys +are treated as if they map to 0. It is an error to increment a value +for an existing key if that value is not an integer. +.TP +\fBdict info \fIdictionaryValue\fR +This returns information (intended for display to people) about the +given dictionary though the format of this data is dependent on the +implementation of the dictionary. For dictionaries that are +implemented by hash tables, it is expected that this will return the +string produced by \fBTcl_HashStats\fR, similar to \fBarray info\fR. +.TP +\fBdict keys \fIdictionaryValue \fR?\fIglobPattern\fR? +Return a list of all keys in the given dictionary value. If a pattern +is supplied, only those keys that match it (according to the rules of +\fBstring match\fR) will be returned. The returned keys will be in an +arbitrary implementation-specific order, though where no pattern is +supplied the i'th key returned by \fBdict keys\fR will be the key for +the i'th value returned by \fBdict values\fR applied to the same +dictionary value. +.TP +\fBdict lappend \fIdictionaryVariable key \fR?\fIvalue ...\fR? +This appends the given items to the list value that the given key maps +to in the dictionary value contained in the given variable, writing +the resulting dictionary value back to that variable. Non-existent +keys are treated as if they map to an empty list, and it is legal for +there to be no items to append to the list. It is an error for the +value that the key maps to to not be representable as a list. +.TP +\fBdict remove \fIdictionaryValue \fR?\fIkey ...\fR? +Return a new dictionary that is a copy of an old one passed in as +first argument except without mappings for each of the keys listed. +It is legal for there to be no keys to remove, and it also legal for +any of the keys to be removed to not be present in the input +dictionary in the first place. +.TP +\fBdict replace \fIdictionaryValue \fR?\fIkey value ...\fR? +Return a new dictionary that is a copy of an old one passed in as +first argument except with some values different or some extra +key/value pairs added. It is legal for this command to be called with +no key/value pairs, but illegal for this command to be called with a +key but no value. +.TP +\fBdict set \fIdictionaryVariable key \fR?\fIkey ...\fR? \fIvalue\fR +This operation takes the name of a variable containing a dictionary +value and places an updated dictionary value in that variable +containing a mapping from the given key to the given value. In a +manner analogous to \fBlset\fR, where multiple keys are present, they +do indexing into nested dictionaries. +.TP +\fBdict size \fIdictionaryValue\fR +Return the number of key/value mappings in the given dictionary value. +.TP +\fBdict unset \fIdictionaryVariable key \fR?\fIkey ...\fR? +This operation (the companion to \fBdict set\fR) takes the name of a +variable containing a dictionary value and places an updated +dictionary value in that variable that does not contain a mapping for +the given key. Where multiple keys are present, this describes a path +through nested dictionaries to the mapping to remove. At least one key +must be specified, but the last key on the key-path need not exist. +All other components on the path must exist. +.TP +\fBdict values \fIdictionaryValue \fR?\fIglobPattern\fR? +Return a list of all values in the given dictionary value. If a +pattern is supplied, only those values that match it (according to the +rules of \fBstring match\fR) will be returned. The returned values +will be in an arbitrary implementation-specific order, though where no +pattern is supplied the i'th key returned by \fBdict keys\fR will be +the key for the i'th value returned by \fBdict values\fR applied to +the same dictionary value. + +.SH "SEE ALSO" +append(n), array(n), foreach(n), incr(n), list(n), lappend(n), set(n) + +.SH KEYWORDS +dictionary, create, update, lookup, iterate, filter diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c new file mode 100644 index 0000000..c59be73 --- /dev/null +++ b/generic/tclDictObj.c @@ -0,0 +1,2558 @@ +/* + * tclDictObj.c -- + * + * This file contains procedures that implement the Tcl dict object + * type and its accessor command. + * + * Copyright (c) 2002 by Donal K. Fellows. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclDictObj.c,v 1.1 2003/04/05 01:03:20 dkf Exp $ + */ + +#include "tclInt.h" + +#if 0 +/* + * Declarations to go to tcl.h + */ +typedef struct { + Tcl_HashSearch search; + int epoch; + Dict *dictionaryPtr; +} Tcl_DictSearch; +/* + * Prototypes to be moved to tcl.decls... + */ +int Tcl_DictObjPut(Tcl_Interp *interp, Tcl_Obj *dictPtr, + Tcl_Obj *keyPtr, Tcl_Obj *valuePtr); +int Tcl_DictObjGet(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, + Tcl_Obj **valuePtrPtr); +int Tcl_DictObjRemove(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr); +int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, int *sizePtr); +int Tcl_DictObjFirst(Tcl_Interp *interp, Tcl_Obj *dictPtr, + Tcl_DictSearch *searchPtr, + Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); +void Tcl_DictObjNext(Tcl_DictSearch *searchPtr, + Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); +void Tcl_DictObjDone(Tcl_DictSearch *searchPtr); +int Tcl_DictObjPutKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr, + int keyc, Tcl_Obj *CONST *keyv, Tcl_Obj *valuePtr); +int Tcl_DictObjRemoveKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr, + int keyc, Tcl_Obj *CONST *keyv); +Tcl_Obj *Tcl_NewDictObj(void); +Tcl_Obj *Tcl_DbNewDictObj(CONST char *file, int line); +/* + * Prototypes to be moved to tclInt.h + */ +int Tcl_DictObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +#endif + +/*----------------------------------------------------------------------*/ + +/* + * Prototypes for procedures defined later in this file: + */ + +static int DictAppendCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static int DictCreateCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static int DictExistsCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static int DictFilterCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static int DictForCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static int DictGetCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static int DictIncrCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static int DictInfoCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static int DictKeysCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static int DictLappendCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static int DictRemoveCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static int DictReplaceCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static int DictSetCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static int DictSizeCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static int DictUnsetCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static int DictValuesCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv)); +static void DupDictInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static void FreeDictInternalRep _ANSI_ARGS_((Tcl_Obj *dictPtr)); +static int SetDictFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static void UpdateStringOfDict _ANSI_ARGS_((Tcl_Obj *dictPtr)); +static Tcl_Obj * TraceDictPath _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *rootPtr, int keyc, Tcl_Obj *CONST keyv[], + int willUpdate)); +struct Dict; +static void DeleteDict _ANSI_ARGS_((struct Dict *dict)); + +/* + * Internal representation of a dictionary. + * + * The internal representation of a dictionary object is a hash table + * (with Tcl_Objs for both keys and values), a reference count and + * epoch number for detecting concurrent modifications of the + * dictionary, and a pointer to the parent object (used when + * invalidating string reps of pathed dictionary trees) which is NULL + * in normal use. The fact that hash tables know (with appropriate + * initialisation) already about objects makes key management /so/ + * much easier! + * + * Reference counts are used to enable safe iteration across hashes + * while allowing the type of the containing object to be modified. + */ + +typedef struct Dict { + Tcl_HashTable table; + int epoch; + int refcount; + Tcl_Obj *chain; +} Dict; + +/* + * The structure below defines the dictionary object type by means of + * procedures that can be invoked by generic object code. + */ + +Tcl_ObjType tclDictType = { + "dict", + FreeDictInternalRep, /* freeIntRepProc */ + DupDictInternalRep, /* dupIntRepProc */ + UpdateStringOfDict, /* updateStringProc */ + SetDictFromAny /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * DupDictInternalRep -- + * + * Initialize the internal representation of a dictionary Tcl_Obj + * to a copy of the internal representation of an existing + * dictionary object. + * + * Results: + * None. + * + * Side effects: + * "srcPtr"s dictionary internal rep pointer should not be NULL and + * we assume it is not NULL. We set "copyPtr"s internal rep to a + * pointer to a newly allocated dictionary rep that, in turn, points + * to "srcPtr"s key and value objects. Those objects are not + * actually copied but are shared between "srcPtr" and "copyPtr". + * The ref count of each key and value object is incremented. + * + *---------------------------------------------------------------------- + */ + +static void +DupDictInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr, *copyPtr; +{ + Dict *oldDict = (Dict *) srcPtr->internalRep.otherValuePtr; + Dict *newDict = (Dict *) ckalloc(sizeof(Dict)); + Tcl_HashEntry *hPtr, *newHPtr; + Tcl_HashSearch search; + Tcl_Obj *keyPtr, *valuePtr; + int isNew; + + /* + * Copy values across from the old hash table. + */ + Tcl_InitObjHashTable(&newDict->table); + for (hPtr=Tcl_FirstHashEntry(&oldDict->table,&search); hPtr!=NULL; + hPtr=Tcl_NextHashEntry(&search)) { + keyPtr = (Tcl_Obj *) Tcl_GetHashKey(&oldDict->table, hPtr); + valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + newHPtr = Tcl_CreateHashEntry(&newDict->table, (char *)keyPtr, &isNew); + Tcl_SetHashValue(newHPtr, (ClientData)valuePtr); + Tcl_IncrRefCount(valuePtr); + } + + /* + * Initialise other fields. + */ + newDict->epoch = 0; + newDict->chain = NULL; + newDict->refcount = 1; + + /* + * Store in the object. + */ + copyPtr->internalRep.otherValuePtr = (VOID *) newDict; + copyPtr->typePtr = &tclDictType; +} + +/* + *---------------------------------------------------------------------- + * + * FreeDictInternalRep -- + * + * Deallocate the storage associated with a dictionary object's + * internal representation. + * + * Results: + * None + * + * Side effects: + * Frees the memory holding the dictionary's internal hash table. + * Decrements the reference count of all key and value objects, + * which may free them. + * + *---------------------------------------------------------------------- + */ + +static void +FreeDictInternalRep(dictPtr) + Tcl_Obj *dictPtr; +{ + Dict *dict = (Dict *) dictPtr->internalRep.otherValuePtr; + + --dict->refcount; + if (dict->refcount == 0) { + DeleteDict(dict); + } + + dictPtr->internalRep.otherValuePtr = NULL; /* Belt and braces! */ +} + +static void +DeleteDict(dict) + Dict *dict; +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_Obj *valuePtr; + + /* + * Delete the values ourselves, because hashes know nothing about + * their contents (but do know about the key type, so that doesn't + * need explicit attention.) + */ + for (hPtr=Tcl_FirstHashEntry(&dict->table,&search); hPtr!=NULL; + hPtr=Tcl_NextHashEntry(&search)) { + valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(valuePtr); + } + Tcl_DeleteHashTable(&dict->table); + ckfree((char *) dict); +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfDict -- + * + * Update the string representation for a dictionary object. + * Note: This procedure does not invalidate an existing old string + * rep so storage will be lost if this has not already been done. + * This code is based on UpdateStringOfList in tclListObj.c + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from + * the dict-to-string conversion. This string will be empty if the + * dictionary has no key/value pairs. The dictionary internal + * representation should not be NULL and we assume it is not NULL. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfDict(dictPtr) + Tcl_Obj *dictPtr; +{ +#define LOCAL_SIZE 20 + int localFlags[LOCAL_SIZE], *flagPtr; + Dict *dict = (Dict *) dictPtr->internalRep.otherValuePtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_Obj *keyPtr, *valuePtr; + int numElems, i, length; + char *elem, *dst; + + /* + * This field is the most useful one in the whole hash structure, + * and it is not exposed by any API function... + */ + numElems = dict->table.numEntries * 2; + + /* + * Pass 1: estimate space, gather flags. + */ + + if (numElems <= LOCAL_SIZE) { + flagPtr = localFlags; + } else { + flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int)); + } + dictPtr->length = 1; + for (i=0,hPtr=Tcl_FirstHashEntry(&dict->table,&search) ; itable, hPtr); + elem = Tcl_GetStringFromObj(keyPtr, &length); + dictPtr->length += Tcl_ScanCountedElement(elem, length, + &flagPtr[i]) + 1; + + valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + elem = Tcl_GetStringFromObj(valuePtr, &length); + dictPtr->length += Tcl_ScanCountedElement(elem, length, + &flagPtr[i+1]) + 1; + } + + /* + * Pass 2: copy into string rep buffer. + */ + + dictPtr->bytes = ckalloc((unsigned) dictPtr->length); + dst = dictPtr->bytes; + for (i=0,hPtr=Tcl_FirstHashEntry(&dict->table,&search) ; itable, hPtr); + elem = Tcl_GetStringFromObj(keyPtr, &length); + dst += Tcl_ConvertCountedElement(elem, length, dst, flagPtr[i]); + *(dst++) = ' '; + + valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + elem = Tcl_GetStringFromObj(valuePtr, &length); + dst += Tcl_ConvertCountedElement(elem, length, dst, flagPtr[i+1]); + *(dst++) = ' '; + } + if (flagPtr != localFlags) { + ckfree((char *) flagPtr); + } + if (dst == dictPtr->bytes) { + *dst = 0; + } else { + *(--dst) = 0; + } + dictPtr->length = dst - dictPtr->bytes; +} + +/* + *---------------------------------------------------------------------- + * + * SetDictFromAny -- + * + * Convert a non-dictionary object into a dictionary object. This + * code is very closely related to SetListFromAny in tclListObj.c + * but does not actually guarantee that a dictionary object will + * have a string rep (as conversions from lists are handled with a + * special case.) + * + * Results: + * A standard Tcl result. + * + * Side effects: + * If the string can be converted, it loses any old internal + * representation that it had and gains a dictionary's internalRep. + * + *---------------------------------------------------------------------- + */ + +static int +SetDictFromAny(interp, objPtr) + Tcl_Interp *interp; + Tcl_Obj *objPtr; +{ + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *string, *s; + CONST char *elemStart, *nextElem; + int lenRemain, length, elemSize, hasBrace, result, isNew; + char *limit; /* Points just after string's last byte. */ + register CONST char *p; + register Tcl_Obj *keyPtr, *valuePtr; + Dict *dict; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + + /* + * Since lists and dictionaries have very closely-related string + * representations (i.e. the same parsing code) we can safely + * special-case the conversion from lists to dictionaries. + */ + + if (oldTypePtr == &tclListType) { + int objc, i; + Tcl_Obj **objv; + + if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { + return TCL_ERROR; + } + if (objc & 1) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("missing value to go with key", -1)); + } + return TCL_ERROR; + } + + /* + * Build the hash of key/value pairs. + */ + dict = (Dict *) ckalloc(sizeof(Dict)); + Tcl_InitObjHashTable(&dict->table); + for (i=0 ; itable, (char *)objv[i], &isNew); + if (!isNew) { + Tcl_Obj *discardedValue = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(discardedValue); + } + Tcl_SetHashValue(hPtr, (ClientData) objv[i+1]); + Tcl_IncrRefCount(objv[i+1]); /* since hash now holds ref to it */ + } + + /* + * Share type-setting code with the string-conversion case. + */ + goto installHash; + } + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = Tcl_GetStringFromObj(objPtr, &length); + limit = (string + length); + + /* + * Allocate a new HashTable that has objects for keys and objects + * for values. + */ + + dict = (Dict *) ckalloc(sizeof(Dict)); + Tcl_InitObjHashTable(&dict->table); + for (p = string, lenRemain = length; + lenRemain > 0; + p = nextElem, lenRemain = (limit - nextElem)) { + result = TclFindElement(interp, p, lenRemain, + &elemStart, &nextElem, &elemSize, &hasBrace); + if (result != TCL_OK) { + goto errorExit; + } + if (elemStart >= limit) { + break; + } + + /* + * Allocate a Tcl object for the element and initialize it from the + * "elemSize" bytes starting at "elemStart". + */ + + s = ckalloc((unsigned) elemSize + 1); + if (hasBrace) { + memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize); + s[elemSize] = 0; + } else { + elemSize = TclCopyAndCollapse(elemSize, elemStart, s); + } + + TclNewObj(keyPtr); + keyPtr->bytes = s; + keyPtr->length = elemSize; + + p = nextElem; + lenRemain = (limit - nextElem); + if (lenRemain <= 0) { + goto missingKey; + } + + result = TclFindElement(interp, p, lenRemain, + &elemStart, &nextElem, &elemSize, &hasBrace); + if (result != TCL_OK) { + Tcl_DecrRefCount(keyPtr); + goto errorExit; + } + if (elemStart >= limit) { + goto missingKey; + } + + /* + * Allocate a Tcl object for the element and initialize it from the + * "elemSize" bytes starting at "elemStart". + */ + + s = ckalloc((unsigned) elemSize + 1); + if (hasBrace) { + memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize); + s[elemSize] = 0; + } else { + elemSize = TclCopyAndCollapse(elemSize, elemStart, s); + } + + TclNewObj(valuePtr); + valuePtr->bytes = s; + valuePtr->length = elemSize; + + /* + * Store key and value in the hash table we're building. + */ + hPtr = Tcl_CreateHashEntry(&dict->table, (char *)keyPtr, &isNew); + if (!isNew) { + Tcl_Obj *discardedValue = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(keyPtr); + Tcl_DecrRefCount(discardedValue); + } + Tcl_SetHashValue(hPtr, (ClientData) valuePtr); + Tcl_IncrRefCount(valuePtr); /* since hash now holds ref to it */ + } + + installHash: + /* + * Free the old internalRep before setting the new one. We do this as + * late as possible to allow the conversion code, in particular + * Tcl_GetStringFromObj, to use that old internalRep. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + dict->epoch = 0; + dict->chain = NULL; + dict->refcount = 1; + objPtr->internalRep.otherValuePtr = (VOID *) dict; + objPtr->typePtr = &tclDictType; + return TCL_OK; + + missingKey: + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("missing value to go with key", -1)); + } + Tcl_DecrRefCount(keyPtr); + result = TCL_ERROR; + errorExit: + for (hPtr=Tcl_FirstHashEntry(&dict->table,&search); + hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) { + valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(valuePtr); + } + Tcl_DeleteHashTable(&dict->table); + ckfree((char *) dict); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TraceDictPath -- + * + * Trace through a tree of dictionaries using the array of keys + * given. If the willUpdate flag is set, a backward-pointing chain + * of dictionaries is also built (in the Dict's chain field) and + * the chained dictionaries are made into unshared dictionaries (if + * they aren't already.) + * + * Results: + * The object at the end of the path, or NULL if there was an error. + * Note that this it is an error for an intermediate dictionary on + * the path to not exist. + * + * Side effects: + * If the willUpdate flag is false, there are no side effects (other + * than potential conversion of objects to dictionaries.) If the + * willUpdate flag is true, the following additional side effects + * occur. Shared dictionaries along the path are converted into + * unshared objects, and a backward-pointing chain is built using + * the chain fields of the dictionaries (for easy invalidation of + * string representations.) + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +TraceDictPath(interp, dictPtr, keyc, keyv, willUpdate) + Tcl_Interp *interp; + Tcl_Obj *dictPtr, *CONST keyv[]; + int keyc, willUpdate; +{ + Dict *dict, *newDict; + int i; + + if (dictPtr->typePtr != &tclDictType) { + if (SetDictFromAny(interp, dictPtr) != TCL_OK) { + return NULL; + } + } + dict = (Dict *) dictPtr->internalRep.otherValuePtr; + if (willUpdate) { + dict->chain = NULL; + } + + for (i=0 ; itable, (char *)keyv[i]); + Tcl_Obj *tmpObj; + + if (hPtr == NULL) { + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "key \"", TclGetString(keyv[i]), + "\" not known in dictionary", NULL); + } + return NULL; + } + + tmpObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + if (tmpObj->typePtr != &tclDictType) { + if (SetDictFromAny(interp, tmpObj) != TCL_OK) { + return NULL; + } + } + newDict = (Dict *) tmpObj->internalRep.otherValuePtr; + if (willUpdate) { + if (Tcl_IsShared(tmpObj)) { + Tcl_DecrRefCount(tmpObj); + tmpObj = Tcl_DuplicateObj(tmpObj); + Tcl_SetHashValue(hPtr, (ClientData) tmpObj); + dict->epoch++; + newDict = (Dict *) tmpObj->internalRep.otherValuePtr; + } + + newDict->chain = dictPtr; + } + dict = newDict; + dictPtr = tmpObj; + } + return dictPtr; +} +static void +InvalidateDictChain(dictObj) + Tcl_Obj *dictObj; +{ + Dict *dict = (Dict *) dictObj->internalRep.otherValuePtr; + + do { + if (dictObj->bytes != NULL) { + Tcl_InvalidateStringRep(dictObj); + } + dict->epoch++; + if ((dictObj = dict->chain) == NULL) { + break; + } + dict->chain = NULL; + dict = (Dict *) dictObj->internalRep.otherValuePtr; + } while (dict != NULL); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DictObjPut -- + * + * Add a key,value pair to a dictionary, or update the value for a + * key if that key already has a mapping in the dictionary. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The object pointed to by dictPtr is converted to a dictionary if + * it is not already one, and any string representation that it has + * is invalidated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr) + Tcl_Interp *interp; + Tcl_Obj *dictPtr, *keyPtr, *valuePtr; +{ + Dict *dict; + Tcl_HashEntry *hPtr; + int isNew; + + if (Tcl_IsShared(dictPtr)) { + panic("Tcl_DictObjPut called with shared object"); + } + + if (dictPtr->typePtr != &tclDictType) { + int result = SetDictFromAny(interp, dictPtr); + if (result != TCL_OK) { + return result; + } + } + + if (dictPtr->bytes != NULL) { + Tcl_InvalidateStringRep(dictPtr); + } + dict = (Dict *) dictPtr->internalRep.otherValuePtr; + hPtr = Tcl_CreateHashEntry(&dict->table, (char *)keyPtr, &isNew); + Tcl_IncrRefCount(valuePtr); + if (!isNew) { + Tcl_Obj *oldValuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(oldValuePtr); + } + Tcl_SetHashValue(hPtr, valuePtr); + dict->epoch++; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DictObjGet -- + * + * Given a key, get its value from the dictionary (or NULL if key + * is not found in dictionary.) + * + * Results: + * A standard Tcl result. The variable pointed to by valuePtrPtr + * is updated with the value for the key. Note that it is not an + * error for the key to have no mapping in the dictionary. + * + * Side effects: + * The object pointed to by dictPtr is converted to a dictionary if + * it is not already one. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DictObjGet(interp, dictPtr, keyPtr, valuePtrPtr) + Tcl_Interp *interp; + Tcl_Obj *dictPtr, *keyPtr, **valuePtrPtr; +{ + Dict *dict; + Tcl_HashEntry *hPtr; + + if (dictPtr->typePtr != &tclDictType) { + int result = SetDictFromAny(interp, dictPtr); + if (result != TCL_OK) { + return result; + } + } + + dict = (Dict *) dictPtr->internalRep.otherValuePtr; + hPtr = Tcl_FindHashEntry(&dict->table, (char *)keyPtr); + if (hPtr == NULL) { + *valuePtrPtr = NULL; + } else { + *valuePtrPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DictObjRemove -- + * + * Remove the key,value pair with the given key from the dictionary; + * the key does not need to be present in the dictionary. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The object pointed to by dictPtr is converted to a dictionary if + * it is not already one, and any string representation that it has + * is invalidated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DictObjRemove(interp, dictPtr, keyPtr) + Tcl_Interp *interp; + Tcl_Obj *dictPtr, *keyPtr; +{ + Dict *dict; + Tcl_HashEntry *hPtr; + + if (Tcl_IsShared(dictPtr)) { + panic("Tcl_DictObjRemove called with shared object"); + } + + if (dictPtr->typePtr != &tclDictType) { + int result = SetDictFromAny(interp, dictPtr); + if (result != TCL_OK) { + return result; + } + } + + if (dictPtr->bytes != NULL) { + Tcl_InvalidateStringRep(dictPtr); + } + dict = (Dict *) dictPtr->internalRep.otherValuePtr; + hPtr = Tcl_FindHashEntry(&dict->table, (char *)keyPtr); + if (hPtr != NULL) { + Tcl_Obj *valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + + Tcl_DecrRefCount(valuePtr); + Tcl_DeleteHashEntry(hPtr); + dict->epoch++; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DictObjSize -- + * + * How many key,value pairs are there in the dictionary? + * + * Results: + * A standard Tcl result. Updates the variable pointed to by + * sizePtr with the number of key,value pairs in the dictionary. + * + * Side effects: + * The dictPtr object is converted to a dictionary type if it is + * not a dictionary already. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DictObjSize(interp, dictPtr, sizePtr) + Tcl_Interp *interp; + Tcl_Obj *dictPtr; + int *sizePtr; +{ + Dict *dict; + + if (dictPtr->typePtr != &tclDictType) { + int result = SetDictFromAny(interp, dictPtr); + if (result != TCL_OK) { + return result; + } + } + + dict = (Dict *) dictPtr->internalRep.otherValuePtr; + *sizePtr = dict->table.numEntries; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DictObjFirst -- + * + * Start a traversal of the dictionary. Caller must supply the + * search context, pointers for returning key and value, and a + * pointer to allow indication of whether the dictionary has been + * traversed (i.e. the dictionary is empty.) The order of traversal + * is undefined. + * + * Results: + * A standard Tcl result. Updates the variables pointed to by + * keyPtrPtr, valuePtrPtr and donePtr. Either of keyPtrPtr and + * valuePtrPtr may be NULL, in which case the key/value is not made + * available to the caller. + * + * Side effects: + * The dictPtr object is converted to a dictionary type if it is + * not a dictionary already. The search context is initialised if + * the search has not finished. The dictionary's internal rep is + * Tcl_Preserve()d if the dictionary has at least one element. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DictObjFirst(interp, dictPtr, searchPtr, keyPtrPtr, valuePtrPtr, donePtr) + Tcl_Interp *interp; /* For error messages, or NULL if no + * error messages desired. */ + Tcl_Obj *dictPtr; /* Dictionary to traverse. */ + Tcl_DictSearch *searchPtr; /* Pointer to a dict search context. */ + Tcl_Obj **keyPtrPtr; /* Pointer to a variable to have the + * first key written into, or NULL. */ + Tcl_Obj **valuePtrPtr; /* Pointer to a variable to have the + * first value written into, or NULL.*/ + int *donePtr; /* Pointer to a variable which will + * have a 1 written into when there + * are no further values in the + * dictionary, or a 0 otherwise. */ +{ + Dict *dict; + Tcl_HashEntry *hPtr; + + if (dictPtr->typePtr != &tclDictType) { + int result = SetDictFromAny(interp, dictPtr); + if (result != TCL_OK) { + return result; + } + } + + dict = (Dict *) dictPtr->internalRep.otherValuePtr; + hPtr = Tcl_FirstHashEntry(&dict->table, &searchPtr->search); + if (hPtr == NULL) { + *donePtr = 1; + } else { + *donePtr = 0; + searchPtr->dictionaryPtr = (Tcl_Dict) dict; + searchPtr->epoch = dict->epoch; + dict->refcount++; + if (keyPtrPtr != NULL) { + *keyPtrPtr = (Tcl_Obj *) Tcl_GetHashKey(&dict->table, hPtr); + } + if (valuePtrPtr != NULL) { + *valuePtrPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DictObjNext -- + * + * Continue a traversal of a dictionary previously started with + * Tcl_DictObjFirst. This function is safe against concurrent + * modification of the underlying object (including type + * shimmering), treating such situations as if the search has + * terminated, though it is up to the caller to ensure that the + * object itself is not disposed until the search has finished. + * It is _not_ safe against modifications from other threads. + * + * Results: + * Updates the variables pointed to by keyPtrPtr, valuePtrPtr and + * donePtr. Either of keyPtrPtr and valuePtrPtr may be NULL, in + * which case the key/value is not made available to the caller. + * + * Side effects: + * Removes a reference to the dictionary's internal rep if the + * search terminates. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DictObjNext(searchPtr, keyPtrPtr, valuePtrPtr, donePtr) + Tcl_DictSearch *searchPtr; /* Pointer to a hash search context. */ + Tcl_Obj **keyPtrPtr; /* Pointer to a variable to have the + * first key written into, or NULL. */ + Tcl_Obj **valuePtrPtr; /* Pointer to a variable to have the + * first value written into, or NULL.*/ + int *donePtr; /* Pointer to a variable which will + * have a 1 written into when there + * are no further values in the + * dictionary, or a 0 otherwise. */ +{ + Tcl_HashEntry *hPtr; + + /* + * Bail out if the dictionary has had any elements added, modified + * or removed. This *shouldn't* happen, but... + */ + if (((Dict *)searchPtr->dictionaryPtr)->epoch != searchPtr->epoch) { + panic("concurrent dictionary modification and search"); + } + + hPtr = Tcl_NextHashEntry(&searchPtr->search); + if (hPtr == NULL) { + Tcl_DictObjDone(searchPtr); + *donePtr = 1; + return; + } + + *donePtr = 0; + if (keyPtrPtr != NULL) { + *keyPtrPtr = (Tcl_Obj *) Tcl_GetHashKey( + &((Dict *)searchPtr->dictionaryPtr)->table, hPtr); + } + if (valuePtrPtr != NULL) { + *valuePtrPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DictObjDone -- + * + * Call this if you want to stop a search before you reach the + * end of the dictionary (e.g. because of abnormal termination of + * the search.) It should not be used if the search reaches its + * natural end (i.e. if either Tcl_DictObjFirst or Tcl_DictObjNext + * sets its donePtr variable to 1.) + * + * Results: + * None. + * + * Side effects: + * Removes a reference to the dictionary's internal rep. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DictObjDone(searchPtr) + Tcl_DictSearch *searchPtr; /* Pointer to a hash search context. */ +{ + Dict *dict; + + if (searchPtr->epoch != -1) { + searchPtr->epoch = -1; + dict = (Dict *) searchPtr->dictionaryPtr; + dict->refcount--; + if (dict->refcount == 0) { + DeleteDict(dict); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DictObjRemoveKeyList -- + * + * Add a key...key,value pair to a dictionary tree. The main + * dictionary value must not be shared, though sub-dictionaries may + * be. All intermediate dictionaries on the path must exist. + * + * Results: + * A standard Tcl result. Note that in the error case, a message + * is left in interp unless that is NULL. + * + * Side effects: + * If the dictionary and any of its sub-dictionaries on the + * path have string representations, these are invalidated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DictObjPutKeyList(interp, dictPtr, keyc, keyv, valuePtr) + Tcl_Interp *interp; + int keyc; + Tcl_Obj *dictPtr, *CONST keyv[], *valuePtr; +{ + Dict *dict; + Tcl_HashEntry *hPtr; + int isNew; + + if (Tcl_IsShared(dictPtr)) { + panic("Tcl_DictObjPutKeyList called with shared object"); + } + if (keyc < 1) { + panic("Tcl_DictObjPutKeyList called with empty key list"); + } + + dictPtr = TraceDictPath(interp, dictPtr, keyc-1, keyv, /*willUpdate*/ 1); + if (dictPtr == NULL) { + return TCL_ERROR; + } + + dict = (Dict *) dictPtr->internalRep.otherValuePtr; + hPtr = Tcl_CreateHashEntry(&dict->table, (char *)keyv[keyc-1], &isNew); + Tcl_IncrRefCount(valuePtr); + if (!isNew) { + Tcl_Obj *oldValuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(oldValuePtr); + } + Tcl_SetHashValue(hPtr, valuePtr); + InvalidateDictChain(dictPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DictObjRemoveKeyList -- + * + * Remove a key...key,value pair from a dictionary tree (the value + * removed is implicit in the key path.) The main dictionary value + * must not be shared, though sub-dictionaries may be. It is not + * an error if there is no value associated with the given key list, + * but all intermediate dictionaries on the key path must exist. + * + * Results: + * A standard Tcl result. Note that in the error case, a message + * is left in interp unless that is NULL. + * + * Side effects: + * If the dictionary and any of its sub-dictionaries on the key + * path have string representations, these are invalidated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DictObjRemoveKeyList(interp, dictPtr, keyc, keyv) + Tcl_Interp *interp; + int keyc; + Tcl_Obj *dictPtr, *CONST keyv[]; +{ + Dict *dict; + Tcl_HashEntry *hPtr; + + if (Tcl_IsShared(dictPtr)) { + panic("Tcl_DictObjRemoveKeyList called with shared object"); + } + if (keyc < 1) { + panic("Tcl_DictObjRemoveKeyList called with empty key list"); + } + + dictPtr = TraceDictPath(interp, dictPtr, keyc-1, keyv, /*willUpdate*/ 1); + if (dictPtr == NULL) { + return TCL_ERROR; + } + + dict = (Dict *) dictPtr->internalRep.otherValuePtr; + hPtr = Tcl_FindHashEntry(&dict->table, (char *)keyv[keyc-1]); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + InvalidateDictChain(dictPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewListObj -- + * + * This procedure is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates a new dict object + * without any content. + * + * When TCL_MEM_DEBUG is defined, this procedure just returns the + * result of calling the debugging version Tcl_DbNewDictObj. + * + * Results: + * A new dict object is returned; it has no keys defined in it. + * The new object's string representation is left NULL, and the + * ref count of the object is 0. + * + * Side Effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_NewDictObj() +{ +#ifdef TCL_MEM_DEBUG + return Tcl_DbNewDictObj("unknown", 0); +#else /* !TCL_MEM_DEBUG */ + Tcl_Obj *dictPtr; + Dict *dict; + + TclNewObj(dictPtr); + Tcl_InvalidateStringRep(dictPtr); + dict = (Dict *) ckalloc(sizeof(Dict)); + Tcl_InitObjHashTable(&dict->table); + dict->epoch = 0; + dict->chain = NULL; + dictPtr->internalRep.otherValuePtr = (VOID *) dict; + dictPtr->typePtr = &tclDictType; + return dictPtr; +#endif +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewListObj -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new dict objects. It is the + * same as the Tcl_NewDictObj procedure above except that it calls + * Tcl_DbCkalloc directly with the file name and line number from its + * caller. This simplifies debugging since then the [memory active] + * command will report the correct file name and line number when + * reporting objects that haven't been freed. + * + * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * result of calling Tcl_NewDictObj. + * + * Results: + * A new dict object is returned; it has no keys defined in it. + * The new object's string representation is left NULL, and the + * ref count of the object is 0. + * + * Side Effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_DbNewDictObj(file, line) + CONST char *file; + int line; +{ +#ifdef TCL_MEM_DEBUG + Tcl_Obj *dictPtr; + Dict *dict; + + TclDbNewObj(dictPtr, file, line); + Tcl_InvalidateStringRep(dictPtr); + dict = (Dict *) ckalloc(sizeof(Dict)); + Tcl_InitObjHashTable(&dict->table); + dict->epoch = 0; + dict->chain = NULL; + dictPtr->internalRep.otherValuePtr = (VOID *) dict; + dictPtr->typePtr = &tclDictType; + return dictPtr; +#else /* !TCL_MEM_DEBUG */ + return Tcl_NewDictObj(); +#endif +} + +/***** START OF FUNCTIONS IMPLEMENTING TCL COMMANDS *****/ + +/* + *---------------------------------------------------------------------- + * + * DictCreateCmd -- + * + * This function implements the "dict create" Tcl command. + * See the user documentation for details on what it does, and + * TIP#??? for the formal specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DictCreateCmd(interp, objc, objv) + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST *objv; +{ + Tcl_Obj *dictObj; + int i; + + /* + * Must have an even number of arguments; note that number of + * preceding arguments (i.e. "dict create" is also even, which + * makes this much easier.) + */ + if (objc & 1) { + Tcl_WrongNumArgs(interp, 2, objv, "?key value ...?"); + return TCL_ERROR; + } + + dictObj = Tcl_NewDictObj(); + for (i=2 ; itypePtr != &tclDictType) { + int result = SetDictFromAny(interp, dictPtr); + if (result != TCL_OK) { + return result; + } + } + dict = (Dict *)dictPtr->internalRep.otherValuePtr; + Tcl_SetObjResult(interp, + Tcl_NewStringObj(Tcl_HashStats(&dict->table), -1)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DictIncrCmd -- + * + * This function implements the "dict incr" Tcl command. + * See the user documentation for details on what it does, and + * TIP#??? for the formal specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DictIncrCmd(interp, objc, objv) + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST *objv; +{ + Tcl_Obj *dictPtr, *valuePtr, *resultPtr; + int result, incrValue; + + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "varName key ?increment?"); + return TCL_ERROR; + } + + if (objc == 5) { + result = Tcl_GetIntFromObj(interp, objv[4], &incrValue); + if (result != TCL_OK) { + return result; + } + } else { + incrValue = 1; + } + + dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); + if (dictPtr == NULL) { + dictPtr = Tcl_NewDictObj(); + Tcl_DictObjPut(interp, dictPtr, objv[3], Tcl_NewIntObj(incrValue)); + } else { + int iValue; + Tcl_WideInt wValue; + + if (Tcl_IsShared(dictPtr)) { + dictPtr = Tcl_DuplicateObj(dictPtr); + } + + if (Tcl_DictObjGet(interp, dictPtr, objv[3], &valuePtr) != TCL_OK) { + return TCL_ERROR; + } + if (valuePtr == NULL) { + valuePtr = Tcl_NewIntObj(incrValue); + } else if (valuePtr->typePtr == &tclWideIntType) { + Tcl_GetWideIntFromObj(NULL, valuePtr, &wValue); + if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_NewWideIntObj(wValue + incrValue); + } else { + Tcl_SetWideIntObj(valuePtr, wValue + incrValue); + if (dictPtr->bytes != NULL) { + Tcl_InvalidateStringRep(dictPtr); + } + goto valueAlreadyInDictionary; + } + } else if (valuePtr->typePtr == &tclIntType) { + Tcl_GetIntFromObj(NULL, valuePtr, &iValue); + if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_NewIntObj(iValue + incrValue); + } else { + Tcl_SetIntObj(valuePtr, iValue + incrValue); + if (dictPtr->bytes != NULL) { + Tcl_InvalidateStringRep(dictPtr); + } + goto valueAlreadyInDictionary; + } + } else { + result = Tcl_GetWideIntFromObj(interp, valuePtr, &wValue); + if (result != TCL_OK) { + return result; + } + /* + * Determine if we should have got a standard int instead. + */ + if (Tcl_IsShared(valuePtr)) { + if (wValue >= INT_MIN && wValue <= INT_MAX) { + /* + * Convert the type... + */ + Tcl_GetIntFromObj(NULL, valuePtr, &iValue); + valuePtr = Tcl_NewIntObj(iValue + incrValue); + } else { + valuePtr = Tcl_NewWideIntObj(wValue + incrValue); + } + } else { + if (wValue >= INT_MIN && wValue <= INT_MAX) { + Tcl_SetIntObj(valuePtr, + Tcl_WideAsLong(wValue) + incrValue); + } else { + Tcl_SetWideIntObj(valuePtr, wValue + incrValue); + } + if (dictPtr->bytes != NULL) { + Tcl_InvalidateStringRep(dictPtr); + } + goto valueAlreadyInDictionary; + } + } + if (Tcl_DictObjPut(interp, dictPtr, objv[3], valuePtr) != TCL_OK) { + Tcl_DecrRefCount(valuePtr); + return TCL_ERROR; + } + valueAlreadyInDictionary: + } + resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr, + TCL_LEAVE_ERR_MSG); + if (resultPtr == NULL) { + Tcl_DecrRefCount(dictPtr); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DictLappendCmd -- + * + * This function implements the "dict lappend" Tcl command. + * See the user documentation for details on what it does, and + * TIP#??? for the formal specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DictLappendCmd(interp, objc, objv) + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST *objv; +{ + Tcl_Obj *dictPtr, *valuePtr, *resultPtr; + int i, allocatedDict = 0, allocatedValue = 0; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "varName key ?value ...?"); + return TCL_ERROR; + } + + dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); + if (dictPtr == NULL) { + allocatedDict = 1; + dictPtr = Tcl_NewDictObj(); + } else if (Tcl_IsShared(dictPtr)) { + allocatedDict = 1; + dictPtr = Tcl_DuplicateObj(dictPtr); + } + + if (Tcl_DictObjGet(interp, dictPtr, objv[3], &valuePtr) != TCL_OK) { + if (allocatedDict) { + Tcl_DecrRefCount(dictPtr); + } + return TCL_ERROR; + } + + if (valuePtr == NULL) { + valuePtr = Tcl_NewListObj(objc-4, objv+4); + allocatedValue = 1; + } else { + if (Tcl_IsShared(valuePtr)) { + allocatedValue = 1; + valuePtr = Tcl_DuplicateObj(valuePtr); + } + + for (i=4 ; ibytes != NULL) { + Tcl_InvalidateStringRep(dictPtr); + } + + resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr, + TCL_LEAVE_ERR_MSG); + if (resultPtr == NULL) { + if (allocatedDict) { + Tcl_DecrRefCount(dictPtr); + } + return TCL_ERROR; + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DictAppendCmd -- + * + * This function implements the "dict append" Tcl command. + * See the user documentation for details on what it does, and + * TIP#??? for the formal specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DictAppendCmd(interp, objc, objv) + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST *objv; +{ + Tcl_Obj *dictPtr, *valuePtr, *resultPtr; + int i, allocatedDict = 0; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "varName key ?value ...?"); + return TCL_ERROR; + } + + dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); + if (dictPtr == NULL) { + allocatedDict = 1; + dictPtr = Tcl_NewDictObj(); + } else if (Tcl_IsShared(dictPtr)) { + allocatedDict = 1; + dictPtr = Tcl_DuplicateObj(dictPtr); + } + + if (Tcl_DictObjGet(interp, dictPtr, objv[3], &valuePtr) != TCL_OK) { + if (allocatedDict) { + Tcl_DecrRefCount(dictPtr); + } + return TCL_ERROR; + } + + if (valuePtr == NULL) { + TclNewObj(valuePtr); + } else { + if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + } + } + + for (i=4 ; ierrorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + Tcl_DictObjDone(&search); + break; + } else { + Tcl_DictObjDone(&search); + break; + } + } + + Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); + } + + /* + * Stop holding a reference to these objects. + */ + Tcl_DecrRefCount(keyVarObj); + Tcl_DecrRefCount(valueVarObj); + Tcl_DecrRefCount(dictObj); + Tcl_DecrRefCount(scriptObj); + + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * DictSetCmd -- + * + * This function implements the "dict set" Tcl command. + * See the user documentation for details on what it does, and + * TIP#??? for the formal specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DictSetCmd(interp, objc, objv) + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST *objv; +{ + Tcl_Obj *dictPtr, *resultPtr; + int result, allocatedDict = 0; + + if (objc < 5) { + Tcl_WrongNumArgs(interp, 2, objv, "varName key ?key ...? value"); + return TCL_ERROR; + } + + dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); + if (dictPtr == NULL) { + allocatedDict = 1; + dictPtr = Tcl_NewDictObj(); + } else if (Tcl_IsShared(dictPtr)) { + allocatedDict = 1; + dictPtr = Tcl_DuplicateObj(dictPtr); + } + + result = Tcl_DictObjPutKeyList(interp, dictPtr, objc-4, objv+3, + objv[objc-1]); + if (result != TCL_OK) { + if (allocatedDict) { + Tcl_DecrRefCount(dictPtr); + } + return TCL_ERROR; + } + + resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr, + TCL_LEAVE_ERR_MSG); + if (resultPtr == NULL) { + if (allocatedDict) { + Tcl_DecrRefCount(dictPtr); + } + return TCL_ERROR; + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DictUnsetCmd -- + * + * This function implements the "dict unset" Tcl command. + * See the user documentation for details on what it does, and + * TIP#??? for the formal specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DictUnsetCmd(interp, objc, objv) + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST *objv; +{ + Tcl_Obj *dictPtr, *resultPtr; + int result, allocatedDict = 0; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "varName key ?key ...?"); + return TCL_ERROR; + } + + dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); + if (dictPtr == NULL) { + allocatedDict = 1; + dictPtr = Tcl_NewDictObj(); + } else if (Tcl_IsShared(dictPtr)) { + allocatedDict = 1; + dictPtr = Tcl_DuplicateObj(dictPtr); + } + + result = Tcl_DictObjRemoveKeyList(interp, dictPtr, objc-3, objv+3); + if (result != TCL_OK) { + if (allocatedDict) { + Tcl_DecrRefCount(dictPtr); + } + return TCL_ERROR; + } + + resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr, + TCL_LEAVE_ERR_MSG); + if (resultPtr == NULL) { + if (allocatedDict) { + Tcl_DecrRefCount(dictPtr); + } + return TCL_ERROR; + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DictFilterCmd -- + * + * This function implements the "dict filter" Tcl command. + * See the user documentation for details on what it does, and + * TIP#??? for the formal specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DictFilterCmd(interp, objc, objv) + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST *objv; +{ + static CONST char *filters[] = { + "key", "script", "value", NULL + }; + enum FilterTypes { + FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES + }; + Tcl_Obj *dictObj, *scriptObj, *keyVarObj, *valueVarObj; + Tcl_Obj **varv, *keyObj, *valueObj, *resultObj, *boolObj; + Tcl_DictSearch search; + int index, varc, done, result, satisfied; + char *pattern; + char msg[32 + TCL_INTEGER_SPACE]; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "dictionary filterType ..."); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[3], filters, "filterType", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum FilterTypes) index) { + case FILTER_KEYS: + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "dictionary key globPattern"); + return TCL_ERROR; + } + + /* + * Create a dictionary whose keys all match a certain pattern. + */ + if (Tcl_DictObjFirst(interp, objv[2], &search, + &keyObj, &valueObj, &done) != TCL_OK) { + return TCL_ERROR; + } + pattern = TclGetString(objv[4]); + resultObj = Tcl_NewDictObj(); + while (!done) { + if (Tcl_StringMatch(TclGetString(keyObj), pattern)) { + Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + } + Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; + + case FILTER_VALUES: + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "dictionary value globPattern"); + return TCL_ERROR; + } + + /* + * Create a dictionary whose values all match a certain pattern. + */ + if (Tcl_DictObjFirst(interp, objv[2], &search, + &keyObj, &valueObj, &done) != TCL_OK) { + return TCL_ERROR; + } + pattern = TclGetString(objv[4]); + resultObj = Tcl_NewDictObj(); + while (!done) { + if (Tcl_StringMatch(TclGetString(valueObj), pattern)) { + Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + } + Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; + + case FILTER_SCRIPT: + if (objc != 6) { + Tcl_WrongNumArgs(interp, 2, objv, + "dictionary script {keyVar valueVar} filterScript"); + return TCL_ERROR; + } + + /* + * Create a dictionary whose key,value pairs all satisfy a + * script (i.e. get a true boolean result from its + * evaluation.) Massive copying from the "dict for" + * implementation has occurred! + */ + + if (Tcl_ListObjGetElements(interp, objv[4], &varc, &varv) != TCL_OK) { + return TCL_ERROR; + } + if (varc != 2) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "must have exactly two variable names", NULL); + return TCL_ERROR; + } + keyVarObj = varv[0]; + valueVarObj = varv[1]; + dictObj = objv[2]; + scriptObj = objv[5]; + /* + * Make sure that these objects (which we need throughout the + * body of the loop) don't vanish. Note that we also care + * that the dictObj remains a dictionary, which requires + * slightly more elaborate precautions. That we achieve by + * making sure that the type is static throughout and that the + * hash is the same hash throughout; taking a copy of the + * whole thing would be easier, but much less efficient. + */ + Tcl_IncrRefCount(keyVarObj); + Tcl_IncrRefCount(valueVarObj); + Tcl_IncrRefCount(dictObj); + Tcl_IncrRefCount(scriptObj); + + result = Tcl_DictObjFirst(interp, dictObj, + &search, &keyObj, &valueObj, &done); + if (result != TCL_OK) { + Tcl_DecrRefCount(keyVarObj); + Tcl_DecrRefCount(valueVarObj); + Tcl_DecrRefCount(dictObj); + Tcl_DecrRefCount(scriptObj); + return TCL_ERROR; + } + + resultObj = Tcl_NewDictObj(); + + while (!done) { + /* + * Stop the value from getting hit in any way by any + * traces on the key variable. + */ + Tcl_IncrRefCount(keyObj); + Tcl_IncrRefCount(valueObj); + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "couldn't set key variable: \"", + Tcl_GetString(keyVarObj), "\"", (char *) NULL); + result = TCL_ERROR; + goto abnormalResult; + } + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "couldn't set value variable: \"", + Tcl_GetString(keyVarObj), "\"", (char *) NULL); + goto abnormalResult; + } + + result = Tcl_EvalObjEx(interp, scriptObj, 0); + switch (result) { + case TCL_OK: + boolObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(boolObj); + Tcl_ResetResult(interp); + if (Tcl_GetBooleanFromObj(interp, boolObj, + &satisfied) != TCL_OK) { + Tcl_DecrRefCount(boolObj); + result = TCL_ERROR; + goto abnormalResult; + } + Tcl_DecrRefCount(boolObj); + if (satisfied) { + Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + } + case TCL_CONTINUE: + result = TCL_OK; + break; + case TCL_BREAK: + /* + * Force loop termination. Has to be done with a jump + * so we remove references to the dictionary correctly. + */ + Tcl_ResetResult(interp); + Tcl_DictObjDone(&search); + result = TCL_OK; + goto normalResult; + case TCL_ERROR: + sprintf(msg, "\n (\"dict filter\" script line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + default: + goto abnormalResult; + } + + Tcl_DecrRefCount(keyObj); + Tcl_DecrRefCount(valueObj); + + Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); + } + + normalResult: + /* + * Stop holding a reference to these objects. + */ + Tcl_DecrRefCount(keyVarObj); + Tcl_DecrRefCount(valueVarObj); + Tcl_DecrRefCount(dictObj); + Tcl_DecrRefCount(scriptObj); + + if (result == TCL_OK) { + Tcl_SetObjResult(interp, resultObj); + } else { + Tcl_DecrRefCount(resultObj); + } + return result; + } + panic("unexpected fallthrough"); + /* Control never reaches this point. */ + + abnormalResult: + Tcl_DictObjDone(&search); + Tcl_DecrRefCount(keyObj); + Tcl_DecrRefCount(valueObj); + Tcl_DecrRefCount(keyVarObj); + Tcl_DecrRefCount(valueVarObj); + Tcl_DecrRefCount(dictObj); + Tcl_DecrRefCount(scriptObj); + Tcl_DecrRefCount(resultObj); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DictObjCmd -- + * + * This function is invoked to process the "dict" Tcl command. + * See the user documentation for details on what it does, and + * TIP#??? for the formal specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DictObjCmd(/*ignored*/ clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST *objv; +{ + static CONST char *subcommands[] = { + "append", "create", "exists", "filter", "for", + "get", "incr", "info", "keys", "lappend", "remove", + "replace", "set", "size", "unset", "values", NULL + }; + enum DictSubcommands { + DICT_APPEND, DICT_CREATE, DICT_EXISTS, DICT_FILTER, DICT_FOR, + DICT_GET, DICT_INCR, DICT_INFO, DICT_KEYS, DICT_LAPPEND, DICT_REMOVE, + DICT_REPLACE, DICT_SET, DICT_SIZE, DICT_UNSET, DICT_VALUES + }; + int index; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "subcommand", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum DictSubcommands) index) { + case DICT_APPEND: return DictAppendCmd(interp, objc, objv); + case DICT_CREATE: return DictCreateCmd(interp, objc, objv); + case DICT_EXISTS: return DictExistsCmd(interp, objc, objv); + case DICT_FILTER: return DictFilterCmd(interp, objc, objv); + case DICT_FOR: return DictForCmd(interp, objc, objv); + case DICT_GET: return DictGetCmd(interp, objc, objv); + case DICT_INCR: return DictIncrCmd(interp, objc, objv); + case DICT_INFO: return DictInfoCmd(interp, objc, objv); + case DICT_KEYS: return DictKeysCmd(interp, objc, objv); + case DICT_LAPPEND: return DictLappendCmd(interp, objc, objv); + case DICT_REMOVE: return DictRemoveCmd(interp, objc, objv); + case DICT_REPLACE: return DictReplaceCmd(interp, objc, objv); + case DICT_SET: return DictSetCmd(interp, objc, objv); + case DICT_SIZE: return DictSizeCmd(interp, objc, objv); + case DICT_UNSET: return DictUnsetCmd(interp, objc, objv); + case DICT_VALUES: return DictValuesCmd(interp, objc, objv); + } + panic("unexpected fallthrough!"); +} diff --git a/tests/dict.test b/tests/dict.test new file mode 100644 index 0000000..6d27533 --- /dev/null +++ b/tests/dict.test @@ -0,0 +1,706 @@ +# This test file covers the dictionary object type and the dict +# command used to work with values of that type. +# +# 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) 2003 Donal K. Fellows +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: dict.test,v 1.1 2003/04/05 01:03:21 dkf Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +# Procedure to help check the contents of a dictionary. Note that we +# can't just compare the string version because the order of the +# elements is (deliberately) not defined. This is because it is +# dependent on the underlying hash table implementation and also +# potentially on the history of the value itself. Net result: you +# cannot safely assume anything about the ordering of values. +proc getOrder {dictVal args} { + foreach key $args { + lappend result $key [dict get $dictVal $key] + } + lappend result [dict size $dictVal] + return $result +} + +test dict-1.1 {dict command basic syntax} { + list [catch {dict} msg] $msg +} {1 {wrong # args: should be "dict subcommand ?arg ...?"}} +test dict-1.2 {dict command basic syntax} { + list [catch {dict ?} msg] $msg +} {1 {bad subcommand "?": must be append, create, exists, filter, for, get, incr, info, keys, lappend, remove, replace, set, size, unset, or values}} + +test dict-2.1 {dict create command} { + dict create +} {} +test dict-2.2 {dict create command} { + dict create a b +} {a b} +test dict-2.3 {dict create command} { + set result {} + set dict [dict create a b c d] + # Can't compare directly as ordering of values is undefined + foreach key {a c} { + set idx [lsearch -exact $dict $key] + if {$idx & 1} { + error "found $key at odd index $idx in $dict" + } + lappend result [lindex $dict [expr {$idx+1}]] + } + set result +} {b d} +test dict-2.4 {dict create command} { + list [catch {dict create a} msg] $msg +} {1 {wrong # args: should be "dict create ?key value ...?"}} +test dict-2.5 {dict create command} { + list [catch {dict create a b c} msg] $msg +} {1 {wrong # args: should be "dict create ?key value ...?"}} + +test dict-3.1 {dict get command} {dict get {a b} a} b +test dict-3.2 {dict get command} {dict get {a b c d} a} b +test dict-3.3 {dict get command} {dict get {a b c d} c} d +test dict-3.4 {dict get command} { + list [catch {dict get {a b c d} b} msg] $msg +} {1 {key "b" not known in dictionary}} +test dict-3.5 {dict get command} {dict get {a {p q r s} b {u v x y}} a p} q +test dict-3.6 {dict get command} {dict get {a {p q r s} b {u v x y}} a r} s +test dict-3.7 {dict get command} {dict get {a {p q r s} b {u v x y}} b u} v +test dict-3.8 {dict get command} {dict get {a {p q r s} b {u v x y}} b x} y +test dict-3.9 {dict get command} { + list [catch {dict get {a {p q r s} b {u v x y}} a z} msg] $msg +} {1 {key "z" not known in dictionary}} +test dict-3.10 {dict get command} { + list [catch {dict get {a {p q r s} b {u v x y}} c z} msg] $msg +} {1 {key "c" not known in dictionary}} +test dict-3.11 {dict get command} {dict get [dict create a b c d] a} b +test dict-3.12 {dict get command} { + list [catch {dict get} msg] $msg +} {1 {wrong # args: should be "dict get dictionary ?key key ...?"}} +test dict-3.13 {dict get command} { + set dict [dict get {a b c d}] + if {$dict eq "a b c d"} { + subst OK + } elseif {$dict eq "c d a b"} { + subst OK + } else { + set dict + } +} OK +test dict-3.14 {dict get command} { + list [catch {dict get {a b c d} a c} msg] $msg +} {1 {missing value to go with key}} + +test dict-4.1 {dict replace command} { + getOrder [dict replace {a b c d}] a c +} {a b c d 2} +test dict-4.2 {dict replace command} { + getOrder [dict replace {a b c d} e f] a c e +} {a b c d e f 3} +test dict-4.3 {dict replace command} { + getOrder [dict replace {a b c d} c f] a c +} {a b c f 2} +test dict-4.4 {dict replace command} { + getOrder [dict replace {a b c d} c x a y] a c +} {a y c x 2} +test dict-4.5 {dict replace command} { + list [catch {dict replace} msg] $msg +} {1 {wrong # args: should be "dict replace dictionary ?key value ...?"}} +test dict-4.6 {dict replace command} { + list [catch {dict replace {a a} a} msg] $msg +} {1 {wrong # args: should be "dict replace dictionary ?key value ...?"}} +test dict-4.7 {dict replace command} { + list [catch {dict replace {a a a} a b} msg] $msg +} {1 {missing value to go with key}} +test dict-4.8 {dict replace command} { + list [catch {dict replace [list a a a] a b} msg] $msg +} {1 {missing value to go with key}} +test dict-4.9 {dict replace command} {dict replace [list a a] a b} {a b} + +test dict-5.1 {dict remove command} {dict remove {a b c d} a} {c d} +test dict-5.2 {dict remove command} {dict remove {a b c d} c} {a b} +test dict-5.3 {dict remove command} {dict remove {a b c d} a c} {} +test dict-5.4 {dict remove command} {dict remove {a b c d} c a} {} +test dict-5.5 {dict remove command} { + getOrder [dict remove {a b c d}] a c +} {a b c d 2} +test dict-5.6 {dict remove command} {dict remove {a b} c} {a b} +test dict-5.7 {dict remove command} { + list [catch {dict remove} msg] $msg +} {1 {wrong # args: should be "dict remove dictionary ?key ...?"}} + +test dict-6.1 {dict keys command} {dict keys {a b}} a +test dict-6.2 {dict keys command} {dict keys {c d}} c +test dict-6.3 {dict keys command} {lsort [dict keys {a b c d}]} {a c} +test dict-6.4 {dict keys command} {dict keys {a b c d} a} a +test dict-6.5 {dict keys command} {dict keys {a b c d} c} c +test dict-6.6 {dict keys command} {dict keys {a b c d} e} {} +test dict-6.7 {dict keys command} {lsort [dict keys {a b c d ca da} c*]} {c ca} +test dict-6.8 {dict keys command} { + list [catch {dict keys} msg] $msg +} {1 {wrong # args: should be "dict keys dictionary ?pattern?"}} +test dict-6.9 {dict keys command} { + list [catch {dict keys {} a b} msg] $msg +} {1 {wrong # args: should be "dict keys dictionary ?pattern?"}} +test dict-6.10 {dict keys command} { + list [catch {dict keys a} msg] $msg +} {1 {missing value to go with key}} + +test dict-7.1 {dict values command} {dict values {a b}} b +test dict-7.2 {dict values command} {dict values {c d}} d +test dict-7.3 {dict values command} {lsort [dict values {a b c d}]} {b d} +test dict-7.4 {dict values command} {dict values {a b c d} b} b +test dict-7.5 {dict values command} {dict values {a b c d} d} d +test dict-7.6 {dict values command} {dict values {a b c d} e} {} +test dict-7.7 {dict values command} {lsort [dict values {a b c d ca da} d*]} {d da} +test dict-7.8 {dict values command} { + list [catch {dict values} msg] $msg +} {1 {wrong # args: should be "dict values dictionary ?pattern?"}} +test dict-7.9 {dict values command} { + list [catch {dict values {} a b} msg] $msg +} {1 {wrong # args: should be "dict values dictionary ?pattern?"}} +test dict-7.10 {dict values command} { + list [catch {dict values a} msg] $msg +} {1 {missing value to go with key}} + +test dict-8.1 {dict size command} {dict size {}} 0 +test dict-8.2 {dict size command} {dict size {a b}} 1 +test dict-8.3 {dict size command} {dict size {a b c d}} 2 +test dict-8.4 {dict size command} { + list [catch {dict size} msg] $msg +} {1 {wrong # args: should be "dict size dictionary"}} +test dict-8.5 {dict size command} { + list [catch {dict size a b} msg] $msg +} {1 {wrong # args: should be "dict size dictionary"}} +test dict-8.6 {dict size command} { + list [catch {dict size a} msg] $msg +} {1 {missing value to go with key}} + +test dict-9.1 {dict exists command} {dict exists {a b} a} 1 +test dict-9.2 {dict exists command} {dict exists {a b} b} 0 +test dict-9.3 {dict exists command} {dict exists {a {b c}} a b} 1 +test dict-9.4 {dict exists command} {dict exists {a {b c}} a c} 0 +test dict-9.5 {dict exists command} { + list [catch {dict exists {a {b c}} b c} msg] $msg +} {1 {key "b" not known in dictionary}} +test dict-9.6 {dict exists command} { + list [catch {dict exists {a {b c d}} a c} msg] $msg +} {1 {missing value to go with key}} +test dict-9.7 {dict exists command} { + list [catch {dict exists} msg] $msg +} {1 {wrong # args: should be "dict exists dictionary key ?key ...?"}} +test dict-9.8 {dict exists command} { + list [catch {dict exists {}} msg] $msg +} {1 {wrong # args: should be "dict exists dictionary key ?key ...?"}} + +test dict-10.1 {dict info command} { + # Actual string returned by this command is undefined; it is + # intended for human consumption and not for use by scripts. + dict info {} + subst {} +} {} +test dict-10.2 {dict info command} { + list [catch {dict info} msg] $msg +} {1 {wrong # args: should be "dict info dictionary"}} +test dict-10.3 {dict info command} { + list [catch {dict info {} x} msg] $msg +} {1 {wrong # args: should be "dict info dictionary"}} +test dict-10.4 {dict info command} { + list [catch {dict info x} msg] $msg +} {1 {missing value to go with key}} + +test dict-11.1 {dict incr command: unshared value} { + set dictv [dict create \ + a [string index "=0=" 1] \ + b [expr {1+2}] \ + c [expr {wide(0x80000000)+1}]] + getOrder [dict incr dictv a] a b c +} {a 1 b 3 c 2147483649 3} +test dict-11.2 {dict incr command: unshared value} { + set dictv [dict create \ + a [string index "=0=" 1] \ + b [expr {1+2}] \ + c [expr {wide(0x80000000)+1}]] + getOrder [dict incr dictv b] a b c +} {a 0 b 4 c 2147483649 3} +test dict-11.3 {dict incr command: unshared value} { + set dictv [dict create \ + a [string index "=0=" 1] \ + b [expr {1+2}] \ + c [expr {wide(0x80000000)+1}]] + getOrder [dict incr dictv c] a b c +} {a 0 b 3 c 2147483650 3} +test dict-11.4 {dict incr command: shared value} { + set dictv [dict create a 0 b [expr {1+2}] c [expr {wide(0x80000000)+1}]] + set sharing [dict values $dictv] + getOrder [dict incr dictv a] a b c +} {a 1 b 3 c 2147483649 3} +test dict-11.5 {dict incr command: shared value} { + set dictv [dict create a 0 b [expr {1+2}] c [expr {wide(0x80000000)+1}]] + set sharing [dict values $dictv] + getOrder [dict incr dictv b] a b c +} {a 0 b 4 c 2147483649 3} +test dict-11.6 {dict incr command: shared value} { + set dictv [dict create a 0 b [expr {1+2}] c [expr {wide(0x80000000)+1}]] + set sharing [dict values $dictv] + getOrder [dict incr dictv c] a b c +} {a 0 b 3 c 2147483650 3} +test dict-11.7 {dict incr command: unknown values} { + set dictv [dict create a 0 b [expr {1+2}] c [expr {wide(0x80000000)+1}]] + getOrder [dict incr dictv d] a b c d +} {a 0 b 3 c 2147483649 d 1 4} +test dict-11.8 {dict incr command} { + set dictv {a 1} + dict incr dictv a 2 +} {a 3} +test dict-11.9 {dict incr command} { + set dictv {a dummy} + list [catch {dict incr dictv a} msg] $msg +} {1 {expected integer but got "dummy"}} +test dict-11.10 {dict incr command} { + set dictv {a 1} + list [catch {dict incr dictv a dummy} msg] $msg +} {1 {expected integer but got "dummy"}} +test dict-11.11 {dict incr command} { + catch {unset dictv} + dict incr dictv a +} {a 1} +test dict-11.12 {dict incr command} { + set dictv a + list [catch {dict incr dictv a} msg] $msg +} {1 {missing value to go with key}} +test dict-11.13 {dict incr command} { + set dictv a + list [catch {dict incr dictv a a a} msg] $msg +} {1 {wrong # args: should be "dict incr varName key ?increment?"}} +test dict-11.14 {dict incr command} { + set dictv a + list [catch {dict incr dictv} msg] $msg +} {1 {wrong # args: should be "dict incr varName key ?increment?"}} +test dict-11.15 {dict incr command: write failure} { + catch {unset dictVar} + set dictVar(block) {} + set result [list [catch {dict incr dictVar a} msg] $msg] + catch {unset dictVar} + set result +} {1 {can't set "dictVar": variable is array}} + +test dict-12.1 {dict lappend command} { + set dictv {a a} + dict lappend dictv a +} {a a} +test dict-12.2 {dict lappend command} { + set dictv {a a} + set sharing [dict values $dictv] + dict lappend dictv a b +} {a {a b}} +test dict-12.3 {dict lappend command} { + set dictv {a a} + dict lappend dictv a b c +} {a {a b c}} +test dict-12.2 {dict lappend command} { + set dictv [dict create a [string index =a= 1]] + dict lappend dictv a b +} {a {a b}} +test dict-12.4 {dict lappend command} { + set dictv {} + dict lappend dictv a x y z +} {a {x y z}} +test dict-12.5 {dict lappend command} { + catch {unset dictv} + dict lappend dictv a b +} {a b} +test dict-12.6 {dict lappend command} { + set dictv a + list [catch {dict lappend dictv a a} msg] $msg +} {1 {missing value to go with key}} +test dict-12.7 {dict lappend command} { + list [catch {dict lappend} msg] $msg +} {1 {wrong # args: should be "dict lappend varName key ?value ...?"}} +test dict-12.8 {dict lappend command} { + list [catch {dict lappend dictv} msg] $msg +} {1 {wrong # args: should be "dict lappend varName key ?value ...?"}} +test dict-12.9 {dict lappend command} { + set dictv [dict create a "\{"] + list [catch {dict lappend dictv a a} msg] $msg +} {1 {unmatched open brace in list}} +test dict-12.10 {dict lappend command: write failure} { + catch {unset dictVar} + set dictVar(block) {} + set result [list [catch {dict lappend dictVar a x} msg] $msg] + catch {unset dictVar} + set result +} {1 {can't set "dictVar": variable is array}} + +test dict-13.1 {dict append command} { + set dictv {a a} + dict append dictv a +} {a a} +test dict-13.2 {dict append command} { + set dictv {a a} + set sharing [dict values $dictv] + dict append dictv a b +} {a ab} +test dict-13.3 {dict append command} { + set dictv {a a} + dict append dictv a b c +} {a abc} +test dict-13.2 {dict append command} { + set dictv [dict create a [string index =a= 1]] + dict append dictv a b +} {a ab} +test dict-13.4 {dict append command} { + set dictv {} + dict append dictv a x y z +} {a xyz} +test dict-13.5 {dict append command} { + catch {unset dictv} + dict append dictv a b +} {a b} +test dict-13.6 {dict append command} { + set dictv a + list [catch {dict append dictv a a} msg] $msg +} {1 {missing value to go with key}} +test dict-13.7 {dict append command} { + list [catch {dict append} msg] $msg +} {1 {wrong # args: should be "dict append varName key ?value ...?"}} +test dict-13.8 {dict append command} { + list [catch {dict append dictv} msg] $msg +} {1 {wrong # args: should be "dict append varName key ?value ...?"}} +test dict-13.9 {dict append command: write failure} { + catch {unset dictVar} + set dictVar(block) {} + set result [list [catch {dict append dictVar a x} msg] $msg] + catch {unset dictVar} + set result +} {1 {can't set "dictVar": variable is array}} + +test dict-14.1 {dict for command: syntax} { + list [catch {dict for} msg] $msg +} {1 {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}} +test dict-14.2 {dict for command: syntax} { + list [catch {dict for x} msg] $msg +} {1 {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}} +test dict-14.3 {dict for command: syntax} { + list [catch {dict for x x} msg] $msg +} {1 {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}} +test dict-14.4 {dict for command: syntax} { + list [catch {dict for x x x x} msg] $msg +} {1 {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}} +test dict-14.5 {dict for command: syntax} { + list [catch {dict for x x x} msg] $msg +} {1 {must have exactly two variable names}} +test dict-14.6 {dict for command: syntax} { + list [catch {dict for {x x x} x x} msg] $msg +} {1 {must have exactly two variable names}} +test dict-14.7 {dict for command: syntax} { + list [catch {dict for "\{x" x x} msg] $msg +} {1 {unmatched open brace in list}} +test dict-14.8 {dict for command} { + # This test confirms that [dict keys], [dict values] and [dict for] + # all traverse a dictionary in the same order. + set dictv {a A b B c C} + set keys {} + set values {} + dict for {k v} $dictv { + lappend keys $k + lappend values $v + } + set result [expr { + $keys eq [dict keys $dictv] && $values eq [dict values $dictv] + }] + expr {$result ? "YES" : [list "NO" $dictv $keys $values]} +} YES +test dict-14.9 {dict for command} { + dict for {k v} {} { + error "unexpected execution of 'dict for' body" + } +} {} +test dict-14.10 {dict for command: script results} { + set times 0 + dict for {k v} {a a b b} { + incr times + continue + error "shouldn't get here" + } + set times +} 2 +test dict-14.11 {dict for command: script results} { + set times 0 + dict for {k v} {a a b b} { + incr times + break + error "shouldn't get here" + } + set times +} 1 +test dict-14.12 {dict for command: script results} { + set times 0 + list [catch { + dict for {k v} {a a b b} { + incr times + error test + } + } msg] $msg $times $::errorInfo +} {1 test 1 {test + while executing +"error test" + ("dict for" body line 3) + invoked from within +"dict for {k v} {a a b b} { + incr times + error test + }"}} +test dict-14.13 {dict for command: script results} { + proc dicttest {} { + rename dicttest {} + dict for {k v} {a b} { + return ok,$k,$v + error "skipped return completely" + } + error "return didn't go far enough" + } + dicttest +} ok,a,b +test dict-14.14 {dict for command: handle representation loss} { + set dictVar {a b c d e f g h} + set keys {} + set values {} + dict for {k v} $dictVar { + if {[llength $dictVar]} { + lappend keys $k + lappend values $v + } + } + list [lsort $keys] [lsort $values] +} {{a c e g} {b d f h}} +test dict-14.15 {dict for command: keys are unique and iterated over once only} { + set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo} + catch {unset accum} + array set accum {} + dict for {k v} $dictVar { + append accum($k) $v, + } + set result [lsort [array names accum]] + lappend result : + foreach k $result { + catch {lappend result $accum($k)} + } + catch {unset accum} + set result +} {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,} +# There's probably a lot more tests to add here. Really ought to use +# a coverage tool for this job... + +test dict-15.1 {dict set command} { + set dictVar {} + dict set dictVar a x +} {a x} +test dict-15.2 {dict set command} { + set dictvar {a {}} + dict set dictvar a b x +} {a {b x}} +test dict-15.3 {dict set command} { + set dictvar {a {b {}}} + dict set dictvar a b c x +} {a {b {c x}}} +test dict-15.4 {dict set command} { + set dictVar {a y} + dict set dictVar a x +} {a x} +test dict-15.5 {dict set command} { + set dictVar {a {b y}} + dict set dictVar a b x +} {a {b x}} +test dict-15.6 {dict set command} { + set dictVar {a {b {c y}}} + dict set dictVar a b c x +} {a {b {c x}}} +test dict-15.7 {dict set command: no path creation} { + set dictVar {} + list [catch {dict set dictVar a b x} msg] $msg +} {1 {key "a" not known in dictionary}} +test dict-15.8 {dict set command: creates variables} { + catch {unset dictVar} + dict set dictVar a x + set dictVar +} {a x} +test dict-15.9 {dict set command: write failure} { + catch {unset dictVar} + set dictVar(block) {} + set result [list [catch {dict set dictVar a x} msg] $msg] + catch {unset dictVar} + set result +} {1 {can't set "dictVar": variable is array}} +test dict-15.10 {dict set command: syntax} { + list [catch {dict set} msg] $msg +} {1 {wrong # args: should be "dict set varName key ?key ...? value"}} +test dict-15.11 {dict set command: syntax} { + list [catch {dict set a} msg] $msg +} {1 {wrong # args: should be "dict set varName key ?key ...? value"}} +test dict-15.12 {dict set command: syntax} { + list [catch {dict set a a} msg] $msg +} {1 {wrong # args: should be "dict set varName key ?key ...? value"}} +test dict-15.13 {dict set command} { + set dictVar a + list [catch {dict set dictVar b c} msg] $msg +} {1 {missing value to go with key}} + +test dict-16.1 {dict unset command} { + set dictVar {a b c d} + dict unset dictVar a +} {c d} +test dict-16.2 {dict unset command} { + set dictVar {a b c d} + dict unset dictVar c +} {a b} +test dict-16.3 {dict unset command} { + set dictVar {a b} + dict unset dictVar c +} {a b} +test dict-16.4 {dict unset command} { + set dictVar {a {b c d e}} + dict unset dictVar a b +} {a {d e}} +test dict-16.5 {dict unset command} { + set dictVar a + list [catch {dict unset dictVar a} msg] $msg +} {1 {missing value to go with key}} +test dict-16.6 {dict unset command} { + set dictVar {a b} + list [catch {dict unset dictVar c d} msg] $msg +} {1 {key "c" not known in dictionary}} +test dict-16.7 {dict unset command} { + catch {unset dictVar} + list [info exists dictVar] [dict unset dictVar a] [info exists dictVar] +} {0 {} 1} +test dict-16.8 {dict unset command} { + list [catch {dict unset dictVar} msg] $msg +} {1 {wrong # args: should be "dict unset varName key ?key ...?"}} +test dict-16.9 {dict unset command: write failure} { + catch {unset dictVar} + set dictVar(block) {} + set result [list [catch {dict unset dictVar a} msg] $msg] + catch {unset dictVar} + set result +} {1 {can't set "dictVar": variable is array}} + +test dict-17.1 {dict filter command: key} { + set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo} + dict filter $dictVar key a2 +} {a2 b} +test dict-17.2 {dict filter command: key} { + set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo} + dict size [dict filter $dictVar key *] +} 6 +test dict-17.3 {dict filter command: key} { + set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo} + getOrder [dict filter $dictVar key ???] bar foo +} {bar foo foo bar 2} +test dict-17.4 {dict filter command: key} { + list [catch {dict filter {} key} msg] $msg +} {1 {wrong # args: should be "dict filter dictionary key globPattern"}} +test dict-17.5 {dict filter command: key} { + list [catch {dict filter {} key a a} msg] $msg +} {1 {wrong # args: should be "dict filter dictionary key globPattern"}} +test dict-17.6 {dict filter command: value} { + set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo} + dict filter $dictVar value c +} {b1 c} +test dict-17.7 {dict filter command: value} { + set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo} + dict size [dict filter $dictVar value *] +} 6 +test dict-17.8 {dict filter command: value} { + set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo} + getOrder [dict filter $dictVar value ???] bar foo +} {bar foo foo bar 2} +test dict-17.9 {dict filter command: value} { + list [catch {dict filter {} value} msg] $msg +} {1 {wrong # args: should be "dict filter dictionary value globPattern"}} +test dict-17.10 {dict filter command: value} { + list [catch {dict filter {} value a a} msg] $msg +} {1 {wrong # args: should be "dict filter dictionary value globPattern"}} +test dict-17.11 {dict filter command: script} { + set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo} + set n 0 + list [getOrder [dict filter $dictVar script {k v} { + incr n + expr {[string length $k] == [string length $v]} + }] bar foo] $n +} {{bar foo foo bar 2} 6} +test dict-17.12 {dict filter command: script} { + list [catch {dict filter {a b} script {k v} {concat $k $v}} msg] $msg +} {1 {expected boolean value but got "a b"}} +test dict-17.13 {dict filter command: script} { + list [catch {dict filter {a b} script {k v} {error x}} msg] $msg \ + $::errorInfo +} {1 x {x + while executing +"error x" + ("dict filter" script line 1) + invoked from within +"dict filter {a b} script {k v} {error x}"}} +test dict-17.14 {dict filter command: script} { + set n 0 + list [dict filter {a b c d} script {k v} { + incr n + break + error boom! + }] $n +} {{} 1} +test dict-17.15 {dict filter command: script} { + set n 0 + list [dict filter {a b c d} script {k v} { + incr n + continue + error boom! + }] $n +} {{} 2} +test dict-17.16 {dict filter command: script} { + proc dicttest {} { + rename dicttest {} + dict filter {a b} script {k v} { + return ok,$k,$v + error "skipped return completely" + } + error "return didn't go far enough" + } + dicttest +} ok,a,b +test dict-17.17 {dict filter command: script} { + dict filter {a b} script {k k} {continue} + set k +} b +test dict-17.18 {dict filter command: script} { + list [catch {dict filter {a b} script {k k}} msg] $msg +} {1 {wrong # args: should be "dict filter dictionary script {keyVar valueVar} filterScript"}} +test dict-17.19 {dict filter command: script} { + list [catch {dict filter {a b} script k {continue}} msg] $msg +} {1 {must have exactly two variable names}} +test dict-17.20 {dict filter command: script} { + list [catch {dict filter {a b} script "\{k v" {continue}} msg] $msg +} {1 {unmatched open brace in list}} +test dict-17.21 {dict filter command} { + list [catch {dict filter {a b}} msg] $msg +} {1 {wrong # args: should be "dict filter dictionary filterType ..."}} +test dict-17.22 {dict filter command} { + list [catch {dict filter {a b} JUNK} msg] $msg +} {1 {bad filterType "JUNK": must be key, script, or value}} +test dict-17.23 {dict filter command} { + list [catch {dict filter a key *} msg] $msg +} {1 {missing value to go with key}} + +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: -- cgit v0.12