diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | doc/array.n | 20 | ||||
| -rw-r--r-- | generic/tclVar.c | 43 | ||||
| -rw-r--r-- | tests/set-old.test | 45 |
4 files changed, 103 insertions, 16 deletions
@@ -1,3 +1,14 @@ +2000-05-31 Eric Melski <ericm@scriptics.com> + + * generic/tclVar.c (Tcl_ArrayObjCmd): Added support for regexp and + exact matching for [array names] command. [RFE: 3684]. + + * doc/array.n: Added documentation for [array names + -exact/-regexp/-glob] [RFE: 3684]. + + * tests/set-old.test: Added tests for [array names + -exact/-regexp/-glob] [RFE: 3684]. + 2000-05-27 Jeff Hobbs <hobbs@scriptics.com> * tests/info.test: diff --git a/doc/array.n b/doc/array.n index 0f31196..ff610cd 100644 --- a/doc/array.n +++ b/doc/array.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: array.n,v 1.6 2000/05/23 02:45:21 hobbs Exp $ +'\" RCS: @(#) $Id: array.n,v 1.7 2000/05/31 15:03:34 ericm Exp $ '\" .so man.macros .TH array n 8.3 Tcl "Tcl Built-In Commands" @@ -63,15 +63,19 @@ match \fIpattern\fR (using the matching rules of If \fIarrayName\fR isn't the name of an array variable, or if the array contains no elements, then an empty list is returned. .TP -\fBarray names \fIarrayName\fR ?\fIpattern\fR? +\fBarray names \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR? Returns a list containing the names of all of the elements in -the array that match \fIpattern\fR (using the matching -rules of \fBstring match\fR). +the array that match \fIpattern\fR. \fIMode\fR may be one of +\fB-exact\fR, \fB-glob\fR, or \fB-regexp\fR. If specified, \fImode\fR +designates which matching rules to use to match \fIpattern\fR against +the names of the elements in the array. If not specified, \fImode\fR +defaults to \fB-glob\fR. See the documentation for \fBstring match\fR +for information on glob style matching, and the documentation for +\fBregexp\fR for information on regexp matching. If \fIpattern\fR is omitted then the command returns all of -the element names in the array. -If there are no (matching) elements in the array, or if \fIarrayName\fR -isn't the name of an array variable, then an empty string is -returned. +the element names in the array. If there are no (matching) elements +in the array, or if \fIarrayName\fR isn't the name of an array +variable, then an empty string is returned. .TP \fBarray nextelement \fIarrayName searchId\fR Returns the name of the next element in \fIarrayName\fR, or diff --git a/generic/tclVar.c b/generic/tclVar.c index f9d5e32..8c279a0 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.17 2000/05/08 21:25:31 ericm Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.18 2000/05/31 15:03:34 ericm Exp $ */ #include "tclInt.h" @@ -3047,9 +3047,17 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) char *pattern = NULL; char *name; Tcl_Obj *namePtr; + int mode, matched = 0; + static char *options[] = { + "-exact", "-glob", "-regexp", (char *) NULL + }; + enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; + + mode = OPT_GLOB; - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); + if ((objc < 3) && (objc > 5)) { + Tcl_WrongNumArgs(interp, 2, objv, + "arrayName ?mode? ?pattern?"); return TCL_ERROR; } if (notArray) { @@ -3057,7 +3065,13 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } if (objc == 4) { pattern = Tcl_GetString(objv[3]); - } + } else if (objc == 5) { + pattern = Tcl_GetString(objv[4]); + if (Tcl_GetIndexFromObj(interp, objv[3], options, "option", + 0, &mode) != TCL_OK) { + return TCL_ERROR; + } + } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); @@ -3065,8 +3079,25 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) continue; } name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); - if ((objc == 4) && !Tcl_StringMatch(name, pattern)) { - continue; /* element name doesn't match pattern */ + if (objc > 3) { + switch ((enum options) mode) { + case OPT_EXACT: + matched = (strcmp(name, pattern) == 0); + break; + case OPT_GLOB: + matched = Tcl_StringMatch(name, pattern); + break; + case OPT_REGEXP: + matched = Tcl_RegExpMatch(interp, name, + pattern); + if (matched < 0) { + return TCL_ERROR; + } + break; + } + if (matched == 0) { + continue; + } } namePtr = Tcl_NewStringObj(name, -1); diff --git a/tests/set-old.test b/tests/set-old.test index 888a6aa..d9f4084 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: set-old.test,v 1.9 2000/05/08 21:25:31 ericm Exp $ +# RCS: @(#) $Id: set-old.test,v 1.10 2000/05/31 15:03:35 ericm Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -388,7 +388,7 @@ test set-old-8.22 {array command, names option} { catch {unset a} set a(22) 3 list [catch {array names a 4 5} msg] $msg -} {1 {wrong # args: should be "array names arrayName ?pattern?"}} +} {1 {bad option "4": must be -exact, -glob, or -regexp}} test set-old-8.19 {array command, names option} { catch {unset a} array names a @@ -589,6 +589,47 @@ number of buckets with 8 entries: 0 number of buckets with 9 entries: 0 number of buckets with 10 or more entries: 0 average search distance for entry: 1.7" +test set-old-8.49 {array command, array names -exact on glob pattern} { + catch {unset a} + set a(1*2) 1 + list [catch {array names a -exact 1*2} msg] $msg +} {0 1*2} +test set-old-8.48 {array command, array names -glob on glob pattern} { + catch {unset a} + set a(1*2) 1 + set a(12) 1 + set a(11) 1 + list [catch {lsort [array names a -glob 1*2]} msg] $msg +} {0 {1*2 12}} +test set-old-8.49 {array command, array names -regexp on regexp pattern} { + catch {unset a} + set a(1*2) 1 + set a(12) 1 + set a(11) 1 + list [catch {lsort [array names a -regexp ^1]} msg] $msg +} {0 {1*2 11 12}} +test set-old-8.50 {array command, array names -regexp} { + catch {unset a} + set a(-glob) 1 + set a(-regexp) 1 + set a(-exact) 1 + list [catch {array names a -regexp} msg] $msg +} {0 -regexp} +test set-old-8.51 {array command, array names -exact} { + catch {unset a} + set a(-glob) 1 + set a(-regexp) 1 + set a(-exact) 1 + list [catch {array names a -exact} msg] $msg +} {0 -exact} +test set-old-8.52 {array command, array names -glob} { + catch {unset a} + set a(-glob) 1 + set a(-regexp) 1 + set a(-exact) 1 + list [catch {array names a -glob} msg] $msg +} {0 -glob} + test set-old-9.1 {ids for array enumeration} { catch {unset a} |