diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | doc/dict.n | 9 | ||||
| -rw-r--r-- | generic/tclDictObj.c | 96 | ||||
| -rw-r--r-- | tests/dict.test | 35 |
4 files changed, 139 insertions, 8 deletions
@@ -1,3 +1,10 @@ +2004-03-12 Donal K. Fellows <donal.k.fellows@man.ac.uk> + + IMPLEMENTATION OF TIP#163 + * generic/tclDictObj.c (DictMergeCmd): This is based on work by Joe + * tests/dict.test (dict-20.*): English in Tcl [FRQ 745851] + * doc/dict.n: but not exactly. + 2004-03-10 Kevin B. Kenny <kennykb@acm.org> * generic/tclGetDate.y (TclGetDate): Fix so that @@ -4,7 +4,7 @@ '\" 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.2 2003/04/10 13:11:06 dkf Exp $ +'\" RCS: @(#) $Id: dict.n,v 1.3 2004/03/12 23:21:05 dkf Exp $ '\" .so man.macros .TH dict n 8.5 Tcl "Tcl Built-In Commands" @@ -133,6 +133,13 @@ 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 merge \fR?\fIdictionaryValue ...\fR? +Return a dictionary that contains the contents of each of the +\fIdictionaryValue\fR arguments. Where two (or more) dictionaries +contain a mapping for the same key, the resulting dictionary maps that +key to the value according to the last dictionary on the command line +containing a mapping for that key. +.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. diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 8755d4e..bbbc156 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -9,7 +9,7 @@ * 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.14 2004/01/14 22:07:43 dkf Exp $ + * RCS: @(#) $Id: tclDictObj.c,v 1.15 2004/03/12 23:21:05 dkf Exp $ */ #include "tclInt.h" @@ -56,6 +56,8 @@ 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 DictMergeCmd _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, @@ -1467,6 +1469,89 @@ DictRemoveCmd(interp, objc, objv) /* *---------------------------------------------------------------------- * + * DictMergeCmd -- + * + * This function implements the "dict merge" Tcl command. + * See the user documentation for details on what it does, and + * TIP#163 for the formal specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DictMergeCmd(interp, objc, objv) + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST *objv; +{ + Tcl_Obj *targetObj, *keyObj, *valueObj; + int allocatedDict = 0; + int i, done; + Tcl_DictSearch search; + + if (objc == 2) { + /* + * No dictionary arguments; return default (empty value). + */ + return TCL_OK; + } + + if (objc == 3) { + /* + * Single argument, make sure it is a dictionary, but + * otherwise return it. + */ + if (objv[2]->typePtr != &tclDictType) { + if (SetDictFromAny(interp, objv[2]) != TCL_OK) { + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, objv[2]); + return TCL_OK; + } + + /* + * Normal behaviour: combining two (or more) dictionaries. + */ + + targetObj = objv[2]; + if (Tcl_IsShared(targetObj)) { + targetObj = Tcl_DuplicateObj(targetObj); + allocatedDict = 1; + } + for (i=3 ; i<objc ; i++) { + if (Tcl_DictObjFirst(interp, objv[i], &search, &keyObj, &valueObj, + &done) != TCL_OK) { + if (allocatedDict) { + Tcl_DecrRefCount(targetObj); + } + return TCL_ERROR; + } + while (!done) { + if (Tcl_DictObjPut(interp, targetObj, + keyObj, valueObj) != TCL_OK) { + Tcl_DictObjDone(&search); + if (allocatedDict) { + Tcl_DecrRefCount(targetObj); + } + return TCL_ERROR; + } + Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); + } + } + Tcl_SetObjResult(interp, targetObj); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * DictKeysCmd -- * * This function implements the "dict keys" Tcl command. @@ -2595,13 +2680,13 @@ Tcl_DictObjCmd(/*ignored*/ clientData, interp, objc, objv) { static CONST char *subcommands[] = { "append", "create", "exists", "filter", "for", - "get", "incr", "info", "keys", "lappend", "remove", - "replace", "set", "size", "unset", "values", NULL + "get", "incr", "info", "keys", "lappend", "merge", + "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 + DICT_GET, DICT_INCR, DICT_INFO, DICT_KEYS, DICT_LAPPEND, DICT_MERGE, + DICT_REMOVE, DICT_REPLACE, DICT_SET, DICT_SIZE, DICT_UNSET, DICT_VALUES }; int index; @@ -2624,6 +2709,7 @@ Tcl_DictObjCmd(/*ignored*/ clientData, 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_MERGE: return DictMergeCmd(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); diff --git a/tests/dict.test b/tests/dict.test index 61c35b4..215c327 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -9,7 +9,7 @@ # 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.6 2004/01/14 22:07:43 dkf Exp $ +# RCS: @(#) $Id: dict.test,v 1.7 2004/03/12 23:21:06 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -38,7 +38,7 @@ test dict-1.1 {dict command basic syntax} { } {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}} +} {1 {bad subcommand "?": must be append, create, exists, filter, for, get, incr, info, keys, lappend, merge, remove, replace, set, size, unset, or values}} test dict-2.1 {dict create command} { dict create @@ -863,6 +863,37 @@ test dict-19.2 {dict: testing for leaks} -setup { rename stress {} } -result 0 +test dict-20.1 {dict merge command} { + dict merge +} {} +test dict-20.2 {dict merge command} { + getOrder [dict merge {a b c d e f}] a c e +} {a b c d e f 3} +test dict-20.3 {dict merge command} -body { + dict merge {a b c d e} +} -result {missing value to go with key} -returnCodes 1 +test dict-20.4 {dict merge command} { + getOrder [dict merge {a b c d} {e f g h}] a c e g +} {a b c d e f g h 4} +test dict-20.5 {dict merge command} -body { + dict merge {a b c d e} {e f g h} +} -result {missing value to go with key} -returnCodes 1 +test dict-20.6 {dict merge command} -body { + dict merge {a b c d} {e f g h i} +} -result {missing value to go with key} -returnCodes 1 +test dict-20.7 {dict merge command} { + getOrder [dict merge {a b c d e f} {e x g h}] a c e g +} {a b c d e x g h 4} +test dict-20.8 {dict merge command} { + getOrder [dict merge {a b c d} {a x c y}] a c +} {a x c y 2} +test dict-20.9 {dict merge command} { + getOrder [dict merge {a b c d} {a x c y}] a c +} {a x c y 2} +test dict-20.10 {dict merge command} { + getOrder [dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}] a c e 1 3 +} {a - c d e f 1 - 3 4 5} + # cleanup ::tcltest::cleanupTests return |