|
sl@0
|
1 |
# parray:
|
|
sl@0
|
2 |
# Print the contents of a global array on stdout.
|
|
sl@0
|
3 |
#
|
|
sl@0
|
4 |
# RCS: @(#) $Id: parray.tcl,v 1.3 1998/09/14 18:40:03 stanton Exp $
|
|
sl@0
|
5 |
#
|
|
sl@0
|
6 |
# Copyright (c) 1991-1993 The Regents of the University of California.
|
|
sl@0
|
7 |
# Copyright (c) 1994 Sun Microsystems, Inc.
|
|
sl@0
|
8 |
#
|
|
sl@0
|
9 |
# See the file "license.terms" for information on usage and redistribution
|
|
sl@0
|
10 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|
sl@0
|
11 |
#
|
|
sl@0
|
12 |
|
|
sl@0
|
13 |
proc parray {a {pattern *}} {
|
|
sl@0
|
14 |
upvar 1 $a array
|
|
sl@0
|
15 |
if {![array exists array]} {
|
|
sl@0
|
16 |
error "\"$a\" isn't an array"
|
|
sl@0
|
17 |
}
|
|
sl@0
|
18 |
set maxl 0
|
|
sl@0
|
19 |
foreach name [lsort [array names array $pattern]] {
|
|
sl@0
|
20 |
if {[string length $name] > $maxl} {
|
|
sl@0
|
21 |
set maxl [string length $name]
|
|
sl@0
|
22 |
}
|
|
sl@0
|
23 |
}
|
|
sl@0
|
24 |
set maxl [expr {$maxl + [string length $a] + 2}]
|
|
sl@0
|
25 |
foreach name [lsort [array names array $pattern]] {
|
|
sl@0
|
26 |
set nameString [format %s(%s) $a $name]
|
|
sl@0
|
27 |
puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
|
|
sl@0
|
28 |
}
|
|
sl@0
|
29 |
}
|