* tests/set-old.test:

* doc/array.n:
* generic/tclVar.c: Added [array statistics] command [RFE: 4557]

4 files changed, 62 insertions, 8 deletions

diff --git a/ChangeLog b/ChangeLog
index f2b1679..44a25cd 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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} {