diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | doc/array.n | 10 | ||||
| -rw-r--r-- | generic/tclVar.c | 23 | ||||
| -rw-r--r-- | tests/set-old.test | 31 |
4 files changed, 62 insertions, 8 deletions
@@ -1,3 +1,9 @@ +2000-05-08 Eric Melski <ericm@scriptics.com> + + * tests/set-old.test: + * doc/array.n: + * generic/tclVar.c: Added [array statistics] command [RFE: 4557] + 2000-05-06 Andreas Kupries <a.kupries@westend.com> operating as proxy for David Gravereaux <davygrvy@pobox.com> diff --git a/doc/array.n b/doc/array.n index 2a5b1fc..e61403c 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.4 1999/09/21 04:20:35 hobbs Exp $ +'\" RCS: @(#) $Id: array.n,v 1.5 2000/05/08 21:25:30 ericm Exp $ '\" .so man.macros .TH array n 8.3 Tcl "Tcl Built-In Commands" @@ -111,6 +111,14 @@ The return value is a search identifier that must be used in \fBarray nextelement\fR and \fBarray donesearch\fR commands; it allows multiple searches to be underway simultaneously for the same array. +.VS 8.4 +.TP +\fBarray statistics \fIarrayName\fR +Returns statistics about the distribution of data within the hashtable +that represents the array. This information includes the number of +entries in the table, the number of buckets, and the utilization of +the buckets. +.VE 8.4 .VS 8.3 .TP \fBarray unset \fIarrayName\fR ?\fIpattern\fR? diff --git a/generic/tclVar.c b/generic/tclVar.c index 834a8dc..f9d5e32 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.16 2000/01/21 03:29:14 ericm Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.17 2000/05/08 21:25:31 ericm Exp $ */ #include "tclInt.h" @@ -2861,10 +2861,10 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) enum {ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET, ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, - ARRAY_STARTSEARCH, ARRAY_UNSET}; + ARRAY_STARTSEARCH, ARRAY_STATISTICS, ARRAY_UNSET}; static char *arrayOptions[] = { "anymore", "donesearch", "exists", "get", "names", "nextelement", - "set", "size", "startsearch", "unset", (char *) NULL + "set", "size", "startsearch", "statistics", "unset", (char *) NULL }; Interp *iPtr = (Interp *) interp; @@ -3178,7 +3178,22 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) varPtr->searchPtr = searchPtr; break; } - case ARRAY_UNSET: { + + case ARRAY_STATISTICS: { + char *stats; + stats = Tcl_HashStats(varPtr->value.tablePtr); + if (stats != NULL) { + Tcl_SetResult(interp, stats, TCL_VOLATILE); + ckfree((void *)stats); + } else { + Tcl_SetResult(interp, "error reading array statistics", + TCL_STATIC); + return TCL_ERROR; + } + break; + } + + case ARRAY_UNSET: { Tcl_HashSearch search; Var *varPtr2; char *pattern = NULL; diff --git a/tests/set-old.test b/tests/set-old.test index 76ebe19..888a6aa 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.8 2000/04/10 17:19:04 ericm Exp $ +# RCS: @(#) $Id: set-old.test,v 1.9 2000/05/08 21:25:31 ericm Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -296,7 +296,7 @@ test set-old-8.6 {array command} { catch {unset a} set a(22) 3 list [catch {array gorp a} msg] $msg -} {1 {bad option "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, or unset}} +} {1 {bad option "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, statistics, or unset}} test set-old-8.7 {array command, anymore option} { catch {unset a} list [catch {array anymore a x} msg] $msg @@ -564,11 +564,36 @@ test set-old-8.47 {array command, startsearch option, array doesn't exist yet bu } list [catch {p 1} msg] $msg } {1 {"a" isn't an array}} +test set-old-8.48 {array command, statistics option} { + catch {unset a} + set a(abc) 1 + set a(def) 2 + set a(ghi) 3 + set a(jkl) 4 + set a(mno) 5 + set a(pqr) 6 + set a(stu) 7 + set a(vwx) 8 + set a(yz) 9 + array statistics a +} "9 entries in table, 4 buckets +number of buckets with 0 entries: 0 +number of buckets with 1 entries: 0 +number of buckets with 2 entries: 3 +number of buckets with 3 entries: 1 +number of buckets with 4 entries: 0 +number of buckets with 5 entries: 0 +number of buckets with 6 entries: 0 +number of buckets with 7 entries: 0 +number of buckets with 8 entries: 0 +number of buckets with 9 entries: 0 +number of buckets with 10 or more entries: 0 +average search distance for entry: 1.7" test set-old-9.1 {ids for array enumeration} { catch {unset a} set a(a) 1 - list [array st a] [array st a] [array done a s-1-a; array st a] \ + list [array star a] [array star a] [array done a s-1-a; array star a] \ [array done a s-2-a; array d a s-3-a; array start a] } {s-1-a s-2-a s-3-a s-1-a} test set-old-9.2 {array enumeration} { |