summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog11
-rw-r--r--doc/array.n20
-rw-r--r--generic/tclVar.c43
-rw-r--r--tests/set-old.test45
4 files changed, 103 insertions, 16 deletions
diff --git a/ChangeLog b/ChangeLog
index 241dc24..da4aa16 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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}