Tcl Library Source Code

Check-in [e4a05cae84]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:tcllib re-import
Timelines: family | ancestors | tcllib-vendor-branch
Files: files | file ages | folders
SHA1: e4a05cae8464f434c14c8079c35174d36ee22028
User & Date: ericm 2000-02-24 17:44:43
Context
2000-02-24
17:44
tcllib re-import Closed-Leaf check-in: e4a05cae84 user: ericm tags: tcllib-vendor-branch
17:44
initial empty check-in check-in: ca03628808 user: root tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Added ChangeLog.






















>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
2000-02-17  Eric Melski  <[email protected]>

	* modules/profiler/pkgIndex.tcl: package index for profiler.

	* modules/profiler/man.macros: 
	* modules/profiler/profiler.n: Doc for profiler.

	* modules/profiler/profiler.test: Tests for profiler.

	* modules/profiler/profiler.tcl: Simple Tcl function-level profiler.

Added modules/profiler/man.macros.
























































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
'\" The definitions below are for supplemental macros used in Tcl/Tk
'\" manual entries.
'\"
'\" .AP type name in/out ?indent?
'\"	Start paragraph describing an argument to a library procedure.
'\"	type is type of argument (int, etc.), in/out is either "in", "out",
'\"	or "in/out" to describe whether procedure reads or modifies arg,
'\"	and indent is equivalent to second arg of .IP (shouldn't ever be
'\"	needed;  use .AS below instead)
'\"
'\" .AS ?type? ?name?
'\"	Give maximum sizes of arguments for setting tab stops.  Type and
'\"	name are examples of largest possible arguments that will be passed
'\"	to .AP later.  If args are omitted, default tab stops are used.
'\"
'\" .BS
'\"	Start box enclosure.  From here until next .BE, everything will be
'\"	enclosed in one large box.
'\"
'\" .BE
'\"	End of box enclosure.
'\"
'\" .CS
'\"	Begin code excerpt.
'\"
'\" .CE
'\"	End code excerpt.
'\"
'\" .VS ?version? ?br?
'\"	Begin vertical sidebar, for use in marking newly-changed parts
'\"	of man pages.  The first argument is ignored and used for recording
'\"	the version when the .VS was added, so that the sidebars can be
'\"	found and removed when they reach a certain age.  If another argument
'\"	is present, then a line break is forced before starting the sidebar.
'\"
'\" .VE
'\"	End of vertical sidebar.
'\"
'\" .DS
'\"	Begin an indented unfilled display.
'\"
'\" .DE
'\"	End of indented unfilled display.
'\"
'\" .SO
'\"	Start of list of standard options for a Tk widget.  The
'\"	options follow on successive lines, in four columns separated
'\"	by tabs.
'\"
'\" .SE
'\"	End of list of standard options for a Tk widget.
'\"
'\" .OP cmdName dbName dbClass
'\"	Start of description of a specific option.  cmdName gives the
'\"	option's name as specified in the class command, dbName gives
'\"	the option's name in the option database, and dbClass gives
'\"	the option's class in the option database.
'\"
'\" .UL arg1 arg2
'\"	Print arg1 underlined, then print arg2 normally.
'\"
'\" RCS: @(#) $Id: man.macros,v 1.1.1.1 2000/02/24 17:44:43 ericm Exp $
'\"
'\"	# Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
.if t .wh -1.3i ^B
.nr ^l \n(.l
.ad b
'\"	# Start an argument description
.de AP
.ie !"\\$4"" .TP \\$4
.el \{\
.   ie !"\\$2"" .TP \\n()Cu
.   el          .TP 15
.\}
.ta \\n()Au \\n()Bu
.ie !"\\$3"" \{\
\&\\$1	\\fI\\$2\\fP	(\\$3)
.\".b
.\}
.el \{\
.br
.ie !"\\$2"" \{\
\&\\$1	\\fI\\$2\\fP
.\}
.el \{\
\&\\fI\\$1\\fP
.\}
.\}
..
'\"	# define tabbing values for .AP
.de AS
.nr )A 10n
.if !"\\$1"" .nr )A \\w'\\$1'u+3n
.nr )B \\n()Au+15n
.\"
.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
.nr )C \\n()Bu+\\w'(in/out)'u+2n
..
.AS Tcl_Interp Tcl_CreateInterp in/out
'\"	# BS - start boxed text
'\"	# ^y = starting y location
'\"	# ^b = 1
.de BS
.br
.mk ^y
.nr ^b 1u
.if n .nf
.if n .ti 0
.if n \l'\\n(.lu\(ul'
.if n .fi
..
'\"	# BE - end boxed text (draw box now)
.de BE
.nf
.ti 0
.mk ^t
.ie n \l'\\n(^lu\(ul'
.el \{\
.\"	Draw four-sided box normally, but don't draw top of
.\"	box if the box started on an earlier page.
.ie !\\n(^b-1 \{\
\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.el \}\
\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.\}
.fi
.br
.nr ^b 0
..
'\"	# VS - start vertical sidebar
'\"	# ^Y = starting y location
'\"	# ^v = 1 (for troff;  for nroff this doesn't matter)
.de VS
.if !"\\$2"" .br
.mk ^Y
.ie n 'mc \s12\(br\s0
.el .nr ^v 1u
..
'\"	# VE - end of vertical sidebar
.de VE
.ie n 'mc
.el \{\
.ev 2
.nf
.ti 0
.mk ^t
\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
.sp -1
.fi
.ev
.\}
.nr ^v 0
..
'\"	# Special macro to handle page bottom:  finish off current
'\"	# box/sidebar if in box/sidebar mode, then invoked standard
'\"	# page bottom macro.
.de ^B
.ev 2
'ti 0
'nf
.mk ^t
.if \\n(^b \{\
.\"	Draw three-sided box if this is the box's first page,
.\"	draw two sides but no top otherwise.
.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.\}
.if \\n(^v \{\
.nr ^x \\n(^tu+1v-\\n(^Yu
\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
.\}
.bp
'fi
.ev
.if \\n(^b \{\
.mk ^y
.nr ^b 2
.\}
.if \\n(^v \{\
.mk ^Y
.\}
..
'\"	# DS - begin display
.de DS
.RS
.nf
.sp
..
'\"	# DE - end display
.de DE
.fi
.RE
.sp
..
'\"	# SO - start of list of standard options
.de SO
.SH "STANDARD OPTIONS"
.LP
.nf
.ta 4c 8c 12c
.ft B
..
'\"	# SE - end of list of standard options
.de SE
.fi
.ft R
.LP
See the \\fBoptions\\fR manual entry for details on the standard options.
..
'\"	# OP - start of full description for a single option
.de OP
.LP
.nf
.ta 4c
Command-Line Name:	\\fB\\$1\\fR
Database Name:	\\fB\\$2\\fR
Database Class:	\\fB\\$3\\fR
.fi
.IP
..
'\"	# CS - begin code excerpt
.de CS
.RS
.nf
.ta .25i .5i .75i 1i
..
'\"	# CE - end code excerpt
.de CE
.fi
.RE
..
.de UL
\\$1\l'|0\(ul'\\$2
..

Added modules/profiler/pkgIndex.tcl.






















>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded profiler 0.1 [list source [file join $dir profiler.tcl]]

Added modules/profiler/profiler.n.










































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
'\"
'\" Copyright (c) 1998-2000 by Scriptics Corporation.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: profiler.n,v 1.1.1.1 2000/02/24 17:44:43 ericm Exp $
'\" 
.so man.macros
.TH profiler n 0.1 profiler "Tcl Profiler"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
profiler \- Tcl source code profiler
.SH SYNOPSIS
\fBpackage require profiler ?0.1?\fR
.sp
\fB::profiler::init\fR
.sp
\fB::profiler::dump\fR \fIfunctionName\fR
.sp
\fB::profiler::print\fR \fIfunctionName\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fBprofiler\fR package provides a simple Tcl source code
profiler.  It is a function-level profiler; that is, it collects only
function-level information, not the more detailed line-level
information.  It operates by redefining the Tcl \fBproc\fR command.
Profiling is initiated via the \fB::profiler::init\fR command.
.SH COMMANDS
.TP
\fB::profiler::init\fR
Initiate profiling.  All procedures created after this command is
called will be profiled.  To profile an entire application, this
command must be called before any other commands.
.TP
\fB::profiler::dump\fR \fIfunctionName\fR
Dump profiling information for the function \fIfunctionName\fR.
\fIfunctionName\fR must be fully qualifed.  The return result is a
list of key/value pairs, suitable for use with the \fBarray set\fR
command.  The keys used and their values are: 
.RS
.TP
\fBtotalCalls\fR
The total number of times \fIfunctionName\fR was called.
.TP
\fBcallerDist\fB
A list of key/value pairs mapping each calling function that called
\fIfunctionName\fR to the number of times it called \fIfunctionName\fR.
.TP
\fBfirstRuntime\fR
The runtime, in clock clicks, of \fIfunctionName\fR the first time
that it was called. This value is separated from the total amount of
run time for \fIfunctionName\fR because the first call usually
causes the function to be byte-compiled by the Tcl interpreter, and
that compilation can add significantly to the runtime of the function.
.TP
\fBotherRuntime\fR
The sum of the runtimes of the second and all subsequent calls of
\fIfunctionName\fR.
.RE
.TP
\fB::profiler::print\fR \fIfunctionName\fR
Print profiling information for the function \fIfunctionName\fR.
\fIfunctionName\fR must be fully qualifed.  The return result is a
human readable display of the profiling information for \fIfunctionName\fR.

.SH KEYWORDS
profile, performance, speed

Added modules/profiler/profiler.tcl.
















































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
# profiler.tcl --
#
#	Tcl code profiler.
#
# Copyright (c) 1998-2000 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: profiler.tcl,v 1.1.1.1 2000/02/24 17:44:43 ericm Exp $

package provide profiler 0.1

namespace eval ::profiler {
    variable enabled 1
}

# ::profiler::profProc --
#
#	Replacement for the proc command that adds rudimentary profiling
#	capabilities to Tcl.
#
# Arguments:
#	name		name of the procedure
#	arglist		list of arguments
#	body		body of the procedure
#
# Results:
#	None.

proc ::profiler::profProc {name arglist body} {
    variable callCount
    variable firstRuntime
    variable otherRuntime

    # Get the fully qualified name of the proc
    set ns [uplevel [list namespace current]]
    # If the proc call did not happen at the global context and it did not
    # have an absolute namespace qualifier, we have to prepend the current
    # namespace to the command name
    if { ![string equal $ns "::"] } {
	if { ![regexp "^::" $name] } {
	    set name "${ns}::${name}"
	}
    }

    # Set up accounting for this procedure
    set callCount($name) 0
    set firstRuntime($name) 0
    set otherRuntime($name) 0

    # Add some interesting stuff to the body of the proc
    set profBody "
	if { \$::profiler::enabled } {
	    upvar ::profiler::callCount callCount
	    upvar ::profiler::firstRuntime firstRuntime
	    upvar ::profiler::otherRuntime otherRuntime
	    upvar ::profiler::callers callers
	    incr callCount($name)
	    if { \[info level\] == 1 } {
		set caller GLOBAL
	    } else {
		# Get the name of the calling procedure
		set caller \[lindex \[info level -1\] 0\]
		# Remove the ORIG suffix
		set caller \[string range \$caller 0 end-4\]
	    }
	    if { \[info exists callers($name,\$caller)\] } {
		incr callers($name,\$caller)
	    } else {
		set callers($name,\$caller) 1
	    }
	    set ms \[clock clicks\]
	}
	set CODE \[uplevel ${name}ORIG \$args\]
	if { \$::profiler::enabled } {
	    set t \[expr {\[clock clicks\] - \$ms}\]
	    if { \$callCount($name) == 1 } {
		set firstRuntime($name) \$t
	    } else {
		incr otherRuntime($name) \$t
	    }
	}
	return \$CODE
    "
	uplevel 1 [list ::_oldProc ${name}ORIG $arglist $body]
	uplevel 1 [list ::_oldProc $name args $profBody]
	return
}

# ::profiler::init --
#
#	Initialize the profiler.
#
# Arguments:
#	None.
#
# Results:
#	None.  Renames proc to _oldProc and sets an alias for proc to 
#		profiler::profProc

proc ::profiler::init {} {
    rename ::proc ::_oldProc
    interp alias {} proc {} ::profiler::profProc

    return
}

# ::profiler::print --
#
#	Print information about a proc.
#
# Arguments:
#	pattern	pattern of the proc's to get info for.
#
# Results:
#	A human readable printout of info.

proc ::profiler::print {pattern} {
    variable callCount
    variable firstRuntime
    variable otherRuntime
    variable callers
    
    set result ""
    foreach name [lsort [array names callCount $pattern]] {
	append result "Profiling information for $name\n"
	append result "[string repeat = 80]\n"
	append result "total calls:\t$callCount($name)\n"
	append result "dist to callers:\n"
	foreach index [lsort [array names callers $name,*]] {
	    regsub "^$name," $index {} caller
	    append result "$caller:\t$callers($index)\n"
	}
	append result "first runtime:\t$firstRuntime($name)\n"
	append result "other runtime:\t$otherRuntime($name)\n"
	append result "\n"
    }
    return $result
}

# ::profiler::dump --
#
#	Dump out the information for a proc in a big blob.
#
# Arguments:
#	pattern	pattern of the proc's to lookup.
#
# Results:
#	data	data about the proc's.

proc ::profiler::dump {pattern} {
    variable callCount
    variable firstRuntime
    variable otherRuntime
    variable callers

    foreach name [lsort [array names callCount $pattern]] {
	foreach index [lsort [array names callers $name,*]] {
	    regsub "^$name," $index {} caller
	    set thisCallers($caller) $callers($index)
	}
	set result [list totalCalls $callCount($name) \
		callerDist [array get thisCallers] \
		firstRuntime $firstRuntime($name) \
		otherRuntime $otherRuntime($name)]
    }
    return $result
}

Added modules/profiler/profiler.test.


























































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
# Profiler tests.
#
# Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-2000 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: profiler.test,v 1.1.1.1 2000/02/24 17:44:43 ericm Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

test profiler-1.0 {profiler::init redirects the proc command} {
    set c [interp create]
    set result [$c eval {
	#	package require profiler
	source profiler.tcl
	profiler::init
	list [interp alias {} proc] [info commands ::_oldProc]
    }]
    interp delete $c
    set result
} [list ::profiler::profProc ::_oldProc]

test profiler-2.0 {profiler creates two wrapper proc and real proc} {
    set c [interp create]
    set result [$c eval {
	source profiler.tcl
	profiler::init
	proc foo {} {
	    puts "foo!"
	}
	list [info commands foo] [info commands fooORIG]
    }]
    interp delete $c
    set result
} [list foo fooORIG]
test profiler-2.1 {profiler creates procs in correct scope} {
    set c [interp create]
    set result [$c eval {
	source profiler.tcl
	profiler::init
	namespace eval foo {}
	proc ::foo::foo {} {
	    puts "foo!"
	}
	list [info commands ::foo::foo] [info commands ::foo::fooORIG]
    }]
    interp delete $c
    set result
} [list ::foo::foo ::foo::fooORIG]
test profiler-2.2 {profiler creates procs in correct scope} {
    set c [interp create]
    set result [$c eval {
	source profiler.tcl
	profiler::init
	namespace eval foo {
	    proc foo {} {
		puts "foo!"
	    }
	}
	list [info commands ::foo::foo] [info commands ::foo::fooORIG]
    }]
    interp delete $c
    set result
} [list ::foo::foo ::foo::fooORIG]
test profiler-2.3 {profiler creates procs in correct scope} {
    set c [interp create]
    set result [$c eval {
	source profiler.tcl
	profiler::init
	namespace eval foo {
	    namespace eval bar {}
	    proc bar::foo {} {
		puts "foo!"
	    }
	}
	list [info commands ::foo::bar::foo] \
		[info commands ::foo::bar::fooORIG]
    }]
    interp delete $c
    set result
} [list ::foo::bar::foo ::foo::bar::fooORIG]
test profiler-2.4 {profiler creates procs in correct scope} {
    set c [interp create]
    set result [$c eval {
	source profiler.tcl
	profiler::init
	namespace eval foo {
	    proc ::foo {} {
		puts "foo!"
	    }
	}
	list [info commands ::foo] \
		[info commands ::fooORIG]
    }]
    interp delete $c
    set result
} [list ::foo ::fooORIG]

test profiler-3.1 {profiler wrappers do profiling} {
    set c [interp create]
    set result [$c eval {
	source profiler.tcl
	profiler::init
	proc ::foo {} {
	    set foobar 0
	}
	foo
	foo
	foo
	foo
	profiler::dump ::foo
    }]
    interp delete $c
    array set foo $result
    list totalCalls $foo(totalCalls) callerDist $foo(callerDist)
} [list totalCalls 4 callerDist [list GLOBAL 4]]

test profiler-4.1 {profiler::print produces nicer output than dump} {
    set c [interp create]
    set result [$c eval {
	source profiler.tcl
	profiler::init
	proc ::foo {} {
	    set foobar 0
	}
	foo
	foo
	foo
	foo
	profiler::print ::foo
    }]
    interp delete $c
    regsub {first runtime:.*} $result {} result
    set result
} "Profiling information for ::foo
================================================================================
total calls:\t4
dist to callers:
GLOBAL:\t4
"
test profiler-5.1 {profiler respects enabled flag} {
    set c [interp create]
    set result [$c eval {
	source profiler.tcl
	profiler::init
	proc ::foo {} {
	    set foobar 0
	}
	foo
	foo
	foo
	foo
	set profiler::enabled 0
	foo
	foo
	profiler::print ::foo
    }]
    interp delete $c
    regsub {first runtime:.*} $result {} result
    set result
} "Profiling information for ::foo
================================================================================
total calls:\t4
dist to callers:
GLOBAL:\t4
"

::tcltest::cleanupTests

Added modules/struct/man.macros.
























































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
'\" The definitions below are for supplemental macros used in Tcl/Tk
'\" manual entries.
'\"
'\" .AP type name in/out ?indent?
'\"	Start paragraph describing an argument to a library procedure.
'\"	type is type of argument (int, etc.), in/out is either "in", "out",
'\"	or "in/out" to describe whether procedure reads or modifies arg,
'\"	and indent is equivalent to second arg of .IP (shouldn't ever be
'\"	needed;  use .AS below instead)
'\"
'\" .AS ?type? ?name?
'\"	Give maximum sizes of arguments for setting tab stops.  Type and
'\"	name are examples of largest possible arguments that will be passed
'\"	to .AP later.  If args are omitted, default tab stops are used.
'\"
'\" .BS
'\"	Start box enclosure.  From here until next .BE, everything will be
'\"	enclosed in one large box.
'\"
'\" .BE
'\"	End of box enclosure.
'\"
'\" .CS
'\"	Begin code excerpt.
'\"
'\" .CE
'\"	End code excerpt.
'\"
'\" .VS ?version? ?br?
'\"	Begin vertical sidebar, for use in marking newly-changed parts
'\"	of man pages.  The first argument is ignored and used for recording
'\"	the version when the .VS was added, so that the sidebars can be
'\"	found and removed when they reach a certain age.  If another argument
'\"	is present, then a line break is forced before starting the sidebar.
'\"
'\" .VE
'\"	End of vertical sidebar.
'\"
'\" .DS
'\"	Begin an indented unfilled display.
'\"
'\" .DE
'\"	End of indented unfilled display.
'\"
'\" .SO
'\"	Start of list of standard options for a Tk widget.  The
'\"	options follow on successive lines, in four columns separated
'\"	by tabs.
'\"
'\" .SE
'\"	End of list of standard options for a Tk widget.
'\"
'\" .OP cmdName dbName dbClass
'\"	Start of description of a specific option.  cmdName gives the
'\"	option's name as specified in the class command, dbName gives
'\"	the option's name in the option database, and dbClass gives
'\"	the option's class in the option database.
'\"
'\" .UL arg1 arg2
'\"	Print arg1 underlined, then print arg2 normally.
'\"
'\" RCS: @(#) $Id: man.macros,v 1.1.1.1 2000/02/24 17:44:43 ericm Exp $
'\"
'\"	# Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
.if t .wh -1.3i ^B
.nr ^l \n(.l
.ad b
'\"	# Start an argument description
.de AP
.ie !"\\$4"" .TP \\$4
.el \{\
.   ie !"\\$2"" .TP \\n()Cu
.   el          .TP 15
.\}
.ta \\n()Au \\n()Bu
.ie !"\\$3"" \{\
\&\\$1	\\fI\\$2\\fP	(\\$3)
.\".b
.\}
.el \{\
.br
.ie !"\\$2"" \{\
\&\\$1	\\fI\\$2\\fP
.\}
.el \{\
\&\\fI\\$1\\fP
.\}
.\}
..
'\"	# define tabbing values for .AP
.de AS
.nr )A 10n
.if !"\\$1"" .nr )A \\w'\\$1'u+3n
.nr )B \\n()Au+15n
.\"
.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
.nr )C \\n()Bu+\\w'(in/out)'u+2n
..
.AS Tcl_Interp Tcl_CreateInterp in/out
'\"	# BS - start boxed text
'\"	# ^y = starting y location
'\"	# ^b = 1
.de BS
.br
.mk ^y
.nr ^b 1u
.if n .nf
.if n .ti 0
.if n \l'\\n(.lu\(ul'
.if n .fi
..
'\"	# BE - end boxed text (draw box now)
.de BE
.nf
.ti 0
.mk ^t
.ie n \l'\\n(^lu\(ul'
.el \{\
.\"	Draw four-sided box normally, but don't draw top of
.\"	box if the box started on an earlier page.
.ie !\\n(^b-1 \{\
\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.el \}\
\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.\}
.fi
.br
.nr ^b 0
..
'\"	# VS - start vertical sidebar
'\"	# ^Y = starting y location
'\"	# ^v = 1 (for troff;  for nroff this doesn't matter)
.de VS
.if !"\\$2"" .br
.mk ^Y
.ie n 'mc \s12\(br\s0
.el .nr ^v 1u
..
'\"	# VE - end of vertical sidebar
.de VE
.ie n 'mc
.el \{\
.ev 2
.nf
.ti 0
.mk ^t
\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
.sp -1
.fi
.ev
.\}
.nr ^v 0
..
'\"	# Special macro to handle page bottom:  finish off current
'\"	# box/sidebar if in box/sidebar mode, then invoked standard
'\"	# page bottom macro.
.de ^B
.ev 2
'ti 0
'nf
.mk ^t
.if \\n(^b \{\
.\"	Draw three-sided box if this is the box's first page,
.\"	draw two sides but no top otherwise.
.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.\}
.if \\n(^v \{\
.nr ^x \\n(^tu+1v-\\n(^Yu
\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
.\}
.bp
'fi
.ev
.if \\n(^b \{\
.mk ^y
.nr ^b 2
.\}
.if \\n(^v \{\
.mk ^Y
.\}
..
'\"	# DS - begin display
.de DS
.RS
.nf
.sp
..
'\"	# DE - end display
.de DE
.fi
.RE
.sp
..
'\"	# SO - start of list of standard options
.de SO
.SH "STANDARD OPTIONS"
.LP
.nf
.ta 4c 8c 12c
.ft B
..
'\"	# SE - end of list of standard options
.de SE
.fi
.ft R
.LP
See the \\fBoptions\\fR manual entry for details on the standard options.
..
'\"	# OP - start of full description for a single option
.de OP
.LP
.nf
.ta 4c
Command-Line Name:	\\fB\\$1\\fR
Database Name:	\\fB\\$2\\fR
Database Class:	\\fB\\$3\\fR
.fi
.IP
..
'\"	# CS - begin code excerpt
.de CS
.RS
.nf
.ta .25i .5i .75i 1i
..
'\"	# CE - end code excerpt
.de CE
.fi
.RE
..
.de UL
\\$1\l'|0\(ul'\\$2
..

Added modules/struct/pkgIndex.tcl.






















>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded struct 1.0 [list source [file join $dir struct.tcl]]

Added modules/struct/queue.n.




























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
'\"
'\" Copyright (c) 1998-2000 by Scriptics Corporation.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: queue.n,v 1.1.1.1 2000/02/24 17:44:43 ericm Exp $
'\" 
.so man.macros
.TH queue n 8.3 Struct "Tcl Data Structures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::struct::queue \- Create and manipulate queue objects
.SH SYNOPSIS
\fBpackage require struct ?1.0?\fR
.sp
\fB::struct::queue\fR \fIqueueName\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fB::struct::queue\fR command creates a new queue object with an
associated global Tcl command whose name is \fIqueueName\fR.  This command
may be used to invoke various operations on the queue.  It has the
following general form:
.CS
\fIqueueName option \fR?\fIarg arg ...\fR?
.CE
\fIOption\fR and the \fIarg\fRs
determine the exact behavior of the command.  The following
commands are possible for queue objects:
.TP
\fIqueueName \fBclear\fR
Remove all items from the queue.
.TP
\fIqueueName \fBdestroy\fR
Destroy the queue, including its storage space and associated command.
.TP
\fIqueueName \fBget\fR ?\fIcount\fR?
Return the front \fIcount\fR items of the queue and remove them
from the queue.  If \fIcount\fR is not specified, it defaults to 1.
If \fIcount\fR is 1, the result is a simple string; otherwise, it is a list.
If specified, \fIcount\fR must be greater than or equal to 1.  If
there are no items in the queue, this command will return \fIcount\fR
empty strings.
.TP
\fIqueueName \fBpeek\fR ?\fIcount\fR?
Return the front \fIcount\fR items of the queue, without removing them
from the queue.  If \fIcount\fR is not specified, it defaults to 1.
If \fIcount\fR is 1, the result is a simple string; otherwise, it is a list.
If specified, \fIcount\fR must be greater than or equal to 1.  If
there are no items in the queue, this command will return \fIcount\fR
empty strings.
.TP
\fIqueueName \fBput\fR \fIitem\fR ?\fIitem ...\fR?
Put the item or items specified into the queue.  If more than one
item is given, they will be added in the order they are listed.
.TP
\fIqueueName \fBsize\fR
Return the number of items in the queue.

.SH KEYWORDS
stack, queue

Added modules/struct/queue.tcl.




















































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
# queue.tcl --
#
#	Queue implementation for Tcl.
#
# Copyright (c) 1998-2000 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: queue.tcl,v 1.1.1.1 2000/02/24 17:44:43 ericm Exp $

namespace eval ::struct {}

namespace eval ::struct::queue {
    # The queues array holds all of the queues you've made
    variable queues
    
    # counter is used to give a unique name for unnamed queues
    variable counter 0

    # commands is the list of subcommands recognized by the queue
    variable commands [list \
	    "clear"	\
	    "destroy"	\
	    "get"	\
	    "peek"	\
	    "put"	\
	    "size"	\
	    ]

    # Only export one command, the one used to instantiate a new queue
    namespace export queue
}

# ::struct::queue::queue --
#
#	Create a new queue with a given name; if no name is given, use
#	queueX, where X is a number.
#
# Arguments:
#	name	name of the queue; if null, generate one.
#
# Results:
#	name	name of the queue created

proc ::struct::queue::queue {{name ""}} {
    variable queues
    variable counter
    
    if { [llength [info level 0]] == 1 } {
	incr counter
	set name "queue${counter}"
    }

    if { ![string equal [info commands ::$name] ""] } {
	error "command \"$name\" already exists, unable to create queue"
    }

    # Initialize the queue as empty
    set queues($name) [list ]

    # Create the command to manipulate the queue
    interp alias {} ::$name {} ::struct::queue::QueueProc $name

    return $name
}

##########################
# Private functions follow

# ::struct::queue::QueueProc --
#
#	Command that processes all queue object commands.
#
# Arguments:
#	name	name of the queue object to manipulate.
#	args	command name and args for the command
#
# Results:
#	Varies based on command to perform

proc ::struct::queue::QueueProc {name {cmd ""} args} {
    # Do minimal args checks here
    if { [llength [info level 0]] == 2 } {
	error "wrong # args: should be \"$name option ?arg arg ...?\""
    }
    
    # Split the args into command and args components
    if { [string equal [info commands ::struct::queue::_$cmd] ""] } {
	variable commands
	set optlist [join $commands ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    return [eval [list ::struct::queue::_$cmd $name] $args]
}

# ::struct::queue::_clear --
#
#	Clear a queue.
#
# Arguments:
#	name	name of the queue object.
#
# Results:
#	None.

proc ::struct::queue::_clear {name} {
    variable queues
    set queues($name) [list ]
    return
}

# ::struct::queue::_destroy --
#
#	Destroy a queue object by removing it's storage space and 
#	eliminating it's proc.
#
# Arguments:
#	name	name of the queue object.
#
# Results:
#	None.

proc ::struct::queue::_destroy {name} {
    variable queues
    unset queues($name)
    interp alias {} ::$name {}
    return
}

# ::struct::queue::_get --
#
#	Get an item from a queue.
#
# Arguments:
#	name	name of the queue object.
#	count	number of items to get; defaults to 1
#
# Results:
#	item	first count items from the queue; if there are not enough 
#		items in the queue, throws an error.

proc ::struct::queue::_get {name {count 1}} {
    variable queues
    if { $count < 1 } {
	error "invalid item count $count"
    }

    if { $count > [llength $queues($name)] } {
	error "insufficient items in queue to fill request"
    }

    if { $count == 1 } {
	# Handle this as a special case, so single item gets aren't listified
	set item [lindex $queues($name) 0]
	set queues($name) [lreplace $queues($name) 0 0]
	return $item
    }

    # Otherwise, return a list of items
    set index [expr {$count - 1}]
    set result [lrange $queues($name) 0 $index]
    set queues($name) [lreplace $queues($name) 0 $index]

    return $result
}

# ::struct::queue::_peek --
#
#	Retrive the value of an item on the queue without removing it.
#
# Arguments:
#	name	name of the queue object.
#	count	number of items to peek; defaults to 1
#
# Results:
#	items	top count items from the queue; if there are not enough items
#		to fufill the request, throws an error.

proc ::struct::queue::_peek {name {count 1}} {
    variable queues
    if { $count < 1 } {
	error "invalid item count $count"
    }

    if { $count > [llength $queues($name)] } {
	error "insufficient items in queue to fill request"
    }

    if { $count == 1 } {
	# Handle this as a special case, so single item pops aren't listified
	return [lindex $queues($name) 0]
    }

    # Otherwise, return a list of items
    set index [expr {$count - 1}]
    return [lrange $queues($name) 0 $index]
}

# ::struct::queue::_put --
#
#	Put an item into a queue.
#
# Arguments:
#	name	name of the queue object
#	args	items to put.
#
# Results:
#	None.

proc ::struct::queue::_put {name args} {
    variable queues
    if { [llength $args] == 0 } {
	error "wrong # args: should be \"$name put item ?item ...?\""
    }
    foreach item $args {
	lappend queues($name) $item
    }
    return
}

# ::struct::queue::_size --
#
#	Return the number of objects on a queue.
#
# Arguments:
#	name	name of the queue object.
#
# Results:
#	count	number of items on the queue.

proc ::struct::queue::_size {name} {
    variable queues
    return [llength $queues($name)]
}

Added modules/struct/queue.test.
































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
# queue.test:  tests for the queue package.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-2000 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: queue.test,v 1.1.1.1 2000/02/24 17:44:43 ericm Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require struct
namespace import struct::*

test queue-0.1 {queue errors} {
    queue myqueue
    catch {queue myqueue} msg
    myqueue destroy
    set msg
} "command \"myqueue\" already exists, unable to create queue"
test queue-0.2 {queue errors} {
    queue myqueue
    catch {myqueue} msg
    myqueue destroy
    set msg
} "wrong # args: should be \"myqueue option ?arg arg ...?\""
test queue-0.3 {queue errors} {
    queue myqueue
    catch {myqueue foo} msg
    myqueue destroy
    set msg
} "bad option \"foo\": must be clear, destroy, get, peek, put, or size"
test queue-0.4 {queue errors} {
    catch {queue set} msg
    set msg
} "command \"set\" already exists, unable to create queue"

test queue-1.1 {queue creation} {
    set foo [queue myqueue]
    set cmd [info commands ::myqueue]
    set size [myqueue size]
    myqueue destroy
    list $foo $cmd $size
} {myqueue ::myqueue 0}
test queue-1.2 {queue creation} {
    set foo [queue]
    set cmd [info commands ::$foo]
    set size [$foo size]
    $foo destroy
    list $foo $cmd $size
} {queue1 ::queue1 0}

test queue-2.1 {queue destroy} {
    queue myqueue
    myqueue destroy
    info commands ::myqueue
} {}

test queue-3.2 {size operation} {
    queue myqueue
    myqueue put a b c d e f g
    set size [myqueue size]
    myqueue destroy
    set size
} 7
test queue-3.3 {size operation} {
    queue myqueue
    myqueue put a b c d e f g
    myqueue get 3
    set size [myqueue size]
    myqueue destroy
    set size
} 4
test queue-3.4 {size operation} {
    queue myqueue
    myqueue put a b c d e f g
    myqueue get 3
    myqueue peek 3
    set size [myqueue size]
    myqueue destroy
    set size
} 4
    
test queue-4.1 {put operation} {
    queue myqueue
    catch {myqueue put} msg
    myqueue destroy
    set msg
} "wrong # args: should be \"myqueue put item ?item ...?\""
test queue-4.2 {put operation, singleton items} {
    queue myqueue
    myqueue put a
    myqueue put b
    myqueue put c
    set result [list [myqueue get] [myqueue get] [myqueue get]]
    myqueue destroy
    set result
} "a b c"
test queue-4.3 {put operation, multiple items} {
    queue myqueue
    myqueue put a b c
    set result [list [myqueue get] [myqueue get] [myqueue get]]
    myqueue destroy
    set result
} "a b c"
test queue-4.4 {put operation, spaces in items} {
    queue myqueue
    myqueue put a b "foo bar"
    set result [list [myqueue get] [myqueue get] [myqueue get]]
    myqueue destroy
    set result
} [list a b "foo bar"]
test queue-4.5 {put operation, bad chars in items} {
    queue myqueue
    myqueue put a b \{
    set result [list [myqueue get] [myqueue get] [myqueue get]]
    myqueue destroy
    set result
} [list a b \{]

test queue-5.1 {get operation} {
    queue myqueue
    myqueue put a
    myqueue put b
    myqueue put c
    set result [list [myqueue get] [myqueue get] [myqueue get]]
    myqueue destroy
    set result
} [list a b c]
test queue-5.2 {get operation, multiple items} {
    queue myqueue
    myqueue put a
    myqueue put b
    myqueue put c
    set result [myqueue get 3]
    myqueue destroy
    set result
} [list a b c]

test queue-6.1 {peek operation} {
    queue myqueue
    myqueue put a
    myqueue put b
    myqueue put c
    set result [list [myqueue peek] [myqueue peek] [myqueue peek]]
    myqueue destroy
    set result
} [list a a a]
test queue-6.2 {get operation, multiple items} {
    queue myqueue
    myqueue put a
    myqueue put b
    myqueue put c
    set result [list [myqueue peek 3] [myqueue get 3]]
    myqueue destroy
    set result
} [list [list a b c] [list a b c]]

test queue-7.1 {clear operation} {
    queue myqueue
    myqueue put a
    myqueue put b
    myqueue put c
    set result [list [myqueue peek 3]]
    myqueue clear
    lappend result [myqueue size]
    myqueue destroy
    set result
} [list [list a b c] 0]

::tcltest::cleanupTests

Added modules/struct/stack.n.




























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
'\"
'\" Copyright (c) 1998-2000 by Scriptics Corporation.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: stack.n,v 1.1.1.1 2000/02/24 17:44:43 ericm Exp $
'\" 
.so man.macros
.TH stack n 1.0 Struct "Tcl Data Structures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::struct::stack \- Create and manipulate stack objects
.SH SYNOPSIS
\fBpackage require struct ?1.0?\fR
.sp
\fB::struct::stack\fR \fIstackName\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fB::struct::stack\fR command creates a new stack object with an
associated global Tcl command whose name is \fIstackName\fR.  This command
may be used to invoke various operations on the stack.  It has the
following general form:
.CS
\fIstackName option \fR?\fIarg arg ...\fR?
.CE
\fIOption\fR and the \fIarg\fRs
determine the exact behavior of the command.  The following
commands are possible for stack objects:
.TP
\fIstackName \fBclear\fR
Remove all items from the stack.
.TP
\fIstackName \fBdestroy\fR
Destroy the stack, including its storage space and associated command.
.TP
\fIstackName \fBpeek\fR ?\fIcount\fR?
Return the top \fIcount\fR items of the stack, without removing them
from the stack.  If \fIcount\fR is not specified, it defaults to 1.
If \fIcount\fR is 1, the result is a simple string; otherwise, it is a list.
If specified, \fIcount\fR must be greater than or equal to 1.  If
there are no items on the stack, this command will return \fIcount\fR
empty strings.
.TP
\fIstackName \fBpop\fR ?\fIcount\fR?
Return the top \fIcount\fR items of the stack and remove them
from the stack.  If \fIcount\fR is not specified, it defaults to 1.
If \fIcount\fR is 1, the result is a simple string; otherwise, it is a list.
If specified, \fIcount\fR must be greater than or equal to 1.  If
there are no items on the stack, this command will return \fIcount\fR
empty strings.
.TP
\fIstackName \fBpush\fR \fIitem\fR ?\fIitem ...\fR?
Push the item or items specified onto the stack.  If more than one
item is given, they will be pushed in the order they are listed.
.TP
\fIstackName \fBsize\fR
Return the number of items on the stack.

.SH KEYWORDS
stack, queue

Added modules/struct/stack.tcl.




























































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
# stack.tcl --
#
#	Stack implementation for Tcl.
#
# Copyright (c) 1998-2000 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: stack.tcl,v 1.1.1.1 2000/02/24 17:44:43 ericm Exp $

namespace eval ::struct {}

namespace eval ::struct::stack {
    # The stacks array holds all of the stacks you've made
    variable stacks
    
    # counter is used to give a unique name for unnamed stacks
    variable counter 0

    # commands is the list of subcommands recognized by the stack
    variable commands [list \
	    "clear"	\
	    "destroy"	\
	    "peek"	\
	    "pop"	\
	    "push"	\
	    "rotate"	\
	    "size"	\
	    ]

    # Only export one command, the one used to instantiate a new stack
    namespace export stack
}

# ::struct::stack::stack --
#
#	Create a new stack with a given name; if no name is given, use
#	stackX, where X is a number.
#
# Arguments:
#	name	name of the stack; if null, generate one.
#
# Results:
#	name	name of the stack created

proc ::struct::stack::stack {{name ""}} {
    variable stacks
    variable counter
    
    if { [llength [info level 0]] == 1 } {
	incr counter
	set name "stack${counter}"
    }

    if { ![string equal [info commands ::$name] ""] } {
	error "command \"$name\" already exists, unable to create stack"
    }
    set stacks($name) [list ]

    # Create the command to manipulate the stack
    interp alias {} ::$name {} ::struct::stack::StackProc $name

    return $name
}

##########################
# Private functions follow

# ::struct::stack::StackProc --
#
#	Command that processes all stack object commands.
#
# Arguments:
#	name	name of the stack object to manipulate.
#	args	command name and args for the command
#
# Results:
#	Varies based on command to perform

proc ::struct::stack::StackProc {name {cmd ""} args} {
    # Do minimal args checks here
    if { [llength [info level 0]] == 2 } {
	error "wrong # args: should be \"$name option ?arg arg ...?\""
    }
    
    # Split the args into command and args components
    if { [llength [info commands ::struct::stack::_$cmd]] == 0 } {
	variable commands
	set optlist [join $commands ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    eval [list ::struct::stack::_$cmd $name] $args
}

# ::struct::stack::_clear --
#
#	Clear a stack.
#
# Arguments:
#	name	name of the stack object.
#
# Results:
#	None.

proc ::struct::stack::_clear {name} {
    set ::struct::stack::stacks($name) [list ]
    return
}

# ::struct::stack::_destroy --
#
#	Destroy a stack object by removing it's storage space and 
#	eliminating it's proc.
#
# Arguments:
#	name	name of the stack object.
#
# Results:
#	None.

proc ::struct::stack::_destroy {name} {
    unset ::struct::stack::stacks($name)
    interp alias {} ::$name {}
    return
}

# ::struct::stack::_peek --
#
#	Retrive the value of an item on the stack without popping it.
#
# Arguments:
#	name	name of the stack object.
#	count	number of items to pop; defaults to 1
#
# Results:
#	items	top count items from the stack; if there are not enough items
#		to fufill the request, throws an error.

proc ::struct::stack::_peek {name {count 1}} {
    variable stacks
    if { $count < 1 } {
	error "invalid item count $count"
    }

    if { $count > [llength $stacks($name)] } {
	error "insufficient items on stack to fill request"
    }

    if { $count == 1 } {
	# Handle this as a special case, so single item pops aren't listified
	set item [lindex $stacks($name) end]
	return $item
    }

    # Otherwise, return a list of items
    set result [list ]
    for {set i 0} {$i < $count} {incr i} {
	lappend result [lindex $stacks($name) "end-${i}"]
    }
    return $result
}

# ::struct::stack::_pop --
#
#	Pop an item off a stack.
#
# Arguments:
#	name	name of the stack object.
#	count	number of items to pop; defaults to 1
#
# Results:
#	item	top count items from the stack; if the stack is empty, 
#		returns a list of count nulls.

proc ::struct::stack::_pop {name {count 1}} {
    variable stacks
    if { $count > [llength $stacks($name)] } {
	error "insufficient items on stack to fill request"
    } elseif { $count < 1 } {
	error "invalid item count $count"
    }

    if { $count == 1 } {
	# Handle this as a special case, so single item pops aren't listified
	set item [lindex $stacks($name) end]
	set stacks($name) [lreplace $stacks($name) end end]
	return $item
    }

    # Otherwise, return a list of items
    set result [list ]
    for {set i 0} {$i < $count} {incr i} {
	lappend result [lindex $stacks($name) "end-${i}"]
    }

    # Remove these items from the stack
    incr i -1
    set stacks($name) [lreplace $stacks($name) "end-${i}" end]

    return $result
}

# ::struct::stack::_push --
#
#	Push an item onto a stack.
#
# Arguments:
#	name	name of the stack object
#	args	items to push.
#
# Results:
#	None.

proc ::struct::stack::_push {name args} {
    if { [llength $args] == 0 } {
	error "wrong # args: should be \"$name push item ?item ...?\""
    }
    foreach item $args {
	lappend ::struct::stack::stacks($name) $item
    }
}

# ::struct::stack::_rotate --
#
#	Rotate the top count number of items by step number of steps.
#
# Arguments:
#	name	name of the stack object.
#	count	number of items to rotate.
#	steps	number of steps to rotate.
#
# Results:
#	None.

proc ::struct::stack::_rotate {name count steps} {
    variable stacks
    set len [llength $stacks($name)]
    if { $count > $len } {
	error "insufficient items on stack to fill request"
    }

    # Rotation algorithm:
    # do
    #   Find the insertion point in the stack
    #   Move the end item to the insertion point
    # repeat $steps times

    set start [expr {$len - $count}]
    set steps [expr {$steps % $count}]
    for {set i 0} {$i < $steps} {incr i} {
	set item [lindex $stacks($name) end]
	set stacks($name) [lreplace $stacks($name) end end]
	set stacks($name) [linsert $stacks($name) $start $item]
    }
    return
}

# ::struct::stack::_size --
#
#	Return the number of objects on a stack.
#
# Arguments:
#	name	name of the stack object.
#
# Results:
#	count	number of items on the stack.

proc ::struct::stack::_size {name} {
    return [llength $::struct::stack::stacks($name)]
}

Added modules/struct/stack.test.




















































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
# stack.test:  tests for the stack package.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-2000 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: stack.test,v 1.1.1.1 2000/02/24 17:44:43 ericm Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require struct
namespace import struct::*

test stack-0.1 {stack errors} {
    stack mystack
    catch {stack mystack} msg
    mystack destroy
    set msg
} "command \"mystack\" already exists, unable to create stack"
test stack-0.2 {stack errors} {
    stack mystack
    catch {mystack} msg
    mystack destroy
    set msg
} "wrong # args: should be \"mystack option ?arg arg ...?\""
test stack-0.3 {stack errors} {
    stack mystack
    catch {mystack foo} msg
    mystack destroy
    set msg
} "bad option \"foo\": must be clear, destroy, peek, pop, push, rotate, or size"
test stack-0.4 {stack errors} {
    catch {stack set} msg
    set msg
} "command \"set\" already exists, unable to create stack"

test stack-1.1 {stack creation} {
    set foo [stack mystack]
    set cmd [info commands ::mystack]
    set size [mystack size]
    mystack destroy
    list $foo $cmd $size
} {mystack ::mystack 0}
test stack-1.2 {stack creation} {
    set foo [stack]
    set cmd [info commands ::$foo]
    set size [$foo size]
    $foo destroy
    list $foo $cmd $size
} {stack1 ::stack1 0}

test stack-2.1 {stack destroy} {
    stack mystack
    mystack destroy
    info commands ::mystack
} {}

test stack-3.2 {size operation} {
    stack mystack
    mystack push a b c d e f g
    set size [mystack size]
    mystack destroy
    set size
} 7
test stack-3.3 {size operation} {
    stack mystack
    mystack push a b c d e f g
    mystack pop 3
    set size [mystack size]
    mystack destroy
    set size
} 4
test stack-3.4 {size operation} {
    stack mystack
    mystack push a b c d e f g
    mystack pop 3
    mystack peek 3
    set size [mystack size]
    mystack destroy
    set size
} 4
    
test stack-4.1 {push operation} {
    stack mystack
    catch {mystack push} msg
    mystack destroy
    set msg
} "wrong # args: should be \"mystack push item ?item ...?\""
test stack-4.2 {push operation, singleton items} {
    stack mystack
    mystack push a
    mystack push b
    mystack push c
    set result [list [mystack pop] [mystack pop] [mystack pop]]
    mystack destroy
    set result
} "c b a"
test stack-4.3 {push operation, multiple items} {
    stack mystack
    mystack push a b c
    set result [list [mystack pop] [mystack pop] [mystack pop]]
    mystack destroy
    set result
} "c b a"
test stack-4.4 {push operation, spaces in items} {
    stack mystack
    mystack push a b "foo bar"
    set result [list [mystack pop] [mystack pop] [mystack pop]]
    mystack destroy
    set result
} [list "foo bar" b a]
test stack-4.5 {push operation, bad chars in items} {
    stack mystack
    mystack push a b \{
    set result [list [mystack pop] [mystack pop] [mystack pop]]
    mystack destroy
    set result
} [list \{ b a]

test stack-5.1 {pop operation} {
    stack mystack
    mystack push a
    mystack push b
    mystack push c
    set result [list [mystack pop] [mystack pop] [mystack pop]]
    mystack destroy
    set result
} [list c b a]
test stack-5.2 {pop operation, multiple items} {
    stack mystack
    mystack push a
    mystack push b
    mystack push c
    set result [mystack pop 3]
    mystack destroy
    set result
} [list c b a]

test stack-6.1 {peek operation} {
    stack mystack
    mystack push a
    mystack push b
    mystack push c
    set result [list [mystack peek] [mystack peek] [mystack peek]]
    mystack destroy
    set result
} [list c c c]
test stack-6.2 {pop operation, multiple items} {
    stack mystack
    mystack push a
    mystack push b
    mystack push c
    set result [list [mystack peek 3] [mystack pop 3]]
    mystack destroy
    set result
} [list [list c b a] [list c b a]]

test stack-7.1 {clear operation} {
    stack mystack
    mystack push a
    mystack push b
    mystack push c
    set result [list [mystack peek 3]]
    mystack clear
    lappend result [mystack size]
    mystack destroy
    set result
} [list [list c b a] 0]

test stack-8.1 {rotate operation} {
    stack mystack
    mystack push a b c d e f g h
    mystack rotate 3 1
    set result [mystack peek [mystack size]]
    mystack destroy
    set result
} [list g f h e d c b a]
test stack-8.2 {rotate operation} {
    stack mystack
    mystack push a b c d e f g h
    mystack rotate 3 2
    set result [mystack peek [mystack size]]
    mystack destroy
    set result
} [list f h g e d c b a]
test stack-8.3 {rotate operation} {
    stack mystack
    mystack push a b c d e f g h
    mystack rotate 3 5
    set result [mystack peek [mystack size]]
    mystack destroy
    set result
} [list f h g e d c b a]
test stack-8.4 {rotate operation} {
    stack mystack
    mystack push a b c d e f g h
    mystack rotate 8 1
    set result [mystack peek [mystack size]]
    mystack destroy
    set result
} [list g f e d c b a h]
test stack-8.4 {rotate operation} {
    stack mystack
    mystack push a b c d e f g h
    mystack rotate 8 -1
    set result [mystack peek [mystack size]]
    mystack destroy
    set result
} [list a h g f e d c b]


::tcltest::cleanupTests

Added modules/struct/struct.tcl.




















>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
package provide struct 1.0
source [file join [file dirname [info script]] stack.tcl]
source [file join [file dirname [info script]] queue.tcl]
source [file join [file dirname [info script]] tree.tcl]
namespace eval struct {
	namespace export *
	namespace import stack::*
	namespace import queue::*
	namespace import tree::*
}

Added modules/struct/tree.n.






























































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
'\"
'\" Copyright (c) 1998-2000 by Scriptics Corporation.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: tree.n,v 1.1.1.1 2000/02/24 17:44:43 ericm Exp $
'\" 
.so man.macros
.TH tree n 1.0 Struct "Tcl Data Structures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::struct::tree \- Create and manipulate tree objects
.SH SYNOPSIS
\fBpackage require struct ?1.0?\fR
.sp
\fB::struct::tree\fR \fItreeName\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fB::struct::tree\fR command creates a new tree object with an
associated global Tcl command whose name is \fItreeName\fR.  This command
may be used to invoke various operations on the tree.  It has the
following general form:
.CS
\fItreeName option \fR?\fIarg arg ...\fR?
.CE
\fIOption\fR and the \fIarg\fRs
determine the exact behavior of the command.  The following
commands are possible for tree objects:
.TP
\fItreeName\fR \fBchildren\fR \fInode\fR
Return a list of the children of \fInode\fR.
.TP
\fItreeName\fR \fBdelete\fR \fInode\fR ?\fInode\fR ...?
Remove the specified nodes from the tree.  All of the nodes' children
will be removed as well to prevent orphaned nodes.
.TP
\fItreeName \fBdepth\fR \fInode\fR
Return the number of steps from node \fInode\fR to the root node.
.TP
\fItreeName \fBdestroy\fR
Destroy the tree, including its storage space and associated command.
.TP
\fItreeName\fR \fBexists\fR \fInode\fR
Remove true if the specified node exists in the tree.
.TP
\fItreeName\fR \fBget\fR \fInode\fR ?\fI-key key\fR?
Return the value associated with the key \fIkey\fR for the node
\fInode\fR.  If no key is specified, the key \fBdata\fR is assumed.
.TP
\fItreeName \fBinsert\fR \fIparent\fR \fIindex\fR \fIchild\fR
Insert a node named \fIchild\fR into the tree as a child of the node
\fIparent\fR.  If \fIparent\fR is \fBroot\fR, it refers to the root of
the tree.  The new node will be added to the \fIparent\fR node's
childlist at the index given by \fIindex\fR.
.TP
\fItreeName\fR \fBmove\fR \fIparent\fR \fIindex\fR \fInode\fR 
Make \fInode\fR a child of \fIparent\fR, inserting it
into the parent's child list at the index given by \fIindex\fR.
.TP
\fItreeName\fR \fBparent\fR \fInode\fR
Return the parent of \fInode\fR.
.TP
\fItreeName\fR \fBset\fR \fInode\fR ?\fI-key key\fR? ?\fIvalue\fR?
Set or get one of the keyed values associated with a node.  If no key
is specified, the key \fBdata\fR is assumed.  Each node that is added
to a tree has the value "" assigned to the key \fBdata\fR
automatically.  A node may have any number of keyed values associated
with it.  If \fIvalue\fR is not specified, this command returns the
current value assigned to the key; if \fIvalue\fR is specified, this
command assigns that value to the key.
.TP
\fItreeName\fR \fBsize\fR ?\fInode\fR?
Return a count of the number of descendants of the node \fInode\fR; if
no node is specified, \fBroot\fR is assumed.
.TP
\fItreeName\fR \fBswap\fR \fInode1\fR \fInode2\fR
Swap the position of \fInode1\fR and \fInode2\fR in the tree.
.TP
\fItreeName\fR \fBunset\fR \fInode\fR ?\fI-key key\fR?
Remove a keyed value from the node \fInode\fR.  If no key is
specified, the key \fBdata\fR is assumed.
.TP
\fItreeName\fR \fBwalk\fR \fInode\fR ?\fI-type type\fR? \fI-command cmd\fR
Perform a breadth-first or depth-first walk of the tree starting at
the node \fInode\fR.  The type of walk, breadth-first or depth-first,
is determined by the value of \fItype\fR; \fBbfs\fR indicates
breadth-first, \fBdfs\fR indicates depthe-first.  Depth-first is the
default.  As the walk progresses, the command \fIcmd\fR will be
evaluated at each node, with the values \fItreeName\fR and the name of
the current node appended.

.SH KEYWORDS
tree

Added modules/struct/tree.tcl.
























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
# tree.tcl --
#
#	Implementation of a tree data structure for Tcl.
#
# Copyright (c) 1998-2000 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: tree.tcl,v 1.1.1.1 2000/02/24 17:44:43 ericm Exp $

namespace eval ::struct {}

namespace eval ::struct::tree {
    # Data storage in the tree module
    # -------------------------------
    #
    # There's a lot of bits to keep track of for each tree:
    #	nodes
    #	node values
    #	node relationships
    #
    # It would quickly become unwieldy to try to keep these in arrays or lists
    # within the tree namespace itself.  Instead, each tree structure will get
    # its own namespace.  Each namespace contains:
    #	children	array mapping nodes to their children list
    #	parent		array mapping nodes to their parent node
    #	node:$node	array mapping keys to values for the node $node
    
    # counter is used to give a unique name for unnamed trees
    variable counter 0

    # commands is the list of subcommands recognized by the tree
    variable commands [list \
	    "children"	\
	    "destroy"	\
	    "delete"	\
	    "depth"	\
	    "exists"	\
	    "get"	\
	    "insert"	\
	    "move"	\
	    "parent"	\
	    "set"	\
	    "size"	\
	    "swap"	\
	    "unset"	\
	    "walk"	\
	    ]

    # Only export one command, the one used to instantiate a new tree
    namespace export tree
}

# ::struct::tree::tree --
#
#	Create a new tree with a given name; if no name is given, use
#	treeX, where X is a number.
#
# Arguments:
#	name	name of the tree; if null, generate one.
#
# Results:
#	name	name of the tree created

proc ::struct::tree::tree {{name ""}} {
    variable counter
    
    if { [llength [info level 0]] == 1 } {
	incr counter
	set name "tree${counter}"
    }

    if { ![string equal [info commands ::$name] ""] } {
	error "command \"$name\" already exists, unable to create tree"
    }

    # Set up the namespace
    namespace eval ::struct::tree::tree$name {
	variable children
	set children(root) [list ]

	variable parent
	set parent(root) [list ]

	# Set up the root node's data
	variable noderoot
	set noderoot(data) ""
    }

    # Create the command to manipulate the tree
    interp alias {} ::$name {} ::struct::tree::TreeProc $name

    return $name
}

##########################
# Private functions follow

# ::struct::tree::TreeProc --
#
#	Command that processes all tree object commands.
#
# Arguments:
#	name	name of the tree object to manipulate.
#	args	command name and args for the command
#
# Results:
#	Varies based on command to perform

proc ::struct::tree::TreeProc {name {cmd ""} args} {
    # Do minimal args checks here
    if { [llength [info level 0]] == 2 } {
	error "wrong # args: should be \"$name option ?arg arg ...?\""
    }
    
    # Split the args into command and args components
    if { [llength [info commands ::struct::tree::_$cmd]] == 0 } {
	variable commands
	set optlist [join $commands ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    eval [list ::struct::tree::_$cmd $name] $args
}

# ::struct::tree::_children --
#
#	Return the child list for a given node of a tree.
#
# Arguments:
#	name	name of the tree object.
#	node	node to look up.
#
# Results:
#	children	list of children for the node.

proc ::struct::tree::_children {name node} {
    upvar ::struct::tree::tree${name}::children children
    return $children($node)
}

# ::struct::tree::_destroy --
#
#	Destroy a tree, including its associated command and data storage.
#
# Arguments:
#	name	name of the tree.
#
# Results:
#	None.

proc ::struct::tree::_destroy {name} {
    namespace delete ::struct::tree::tree$name
    interp alias {} ::$name {}
}

# ::struct::tree::_delete --
#
#	Remove a node from a tree, including all of its values.  Recursively
#	removes the node's children.
#
# Arguments:
#	name	name of the tree.
#	node	node to delete.
#
# Results:
#	None.

proc ::struct::tree::_delete {name node} {
    if { [string equal $node "root"] } {
	# Can't delete the special root node
	error "cannot delete root node"
    }
    
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }

    upvar ::struct::tree::tree${name}::children children
    upvar ::struct::tree::tree${name}::parent parent

    # Remove this node from its parent's children list
    set parentNode $parent($node)
    set index [lsearch -exact $children($parentNode) $node]
    set children($parentNode) [lreplace $children($parentNode) $index $index]

    # Yes, we could use the stack structure implemented in ::struct::stack,
    # but it's slower than inlining it.  Since we don't need a sophisticated
    # stack, don't bother.
    set st [list ]
    foreach child $children($node) {
	lappend st $child
    }

    unset children($node)
    unset parent($node)
    unset ::struct::tree::tree${name}::node$node

    while { [llength $st] > 0 } {
	set node [lindex $st end]
	set st [lreplace $st end end]
	foreach child $children($node) {
	    lappend st $child
	}
	unset children($node)
	unset parent($node)
	unset ::struct::tree::tree${name}::node$node
    }
    return
}

# ::struct::tree::_depth --
#
#	Return the depth (distance from the root node) of a given node.
#
# Arguments:
#	name	name of the tree.
#	node	node to find.
#
# Results:
#	depth	number of steps from node to the root node.

proc ::struct::tree::_depth {name node} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    upvar ::struct::tree::tree${name}::parent parent
    set depth 0
    while { ![string equal $node "root"] } {
	incr depth
	set node $parent($node)
    }
    return $depth
}

# ::struct::tree::_exists --
#
#	Test for existance of a given node in a tree.
#
# Arguments:
#	name	name of the tree.
#	node	node to look for.
#
# Results:
#	1 if the node exists, 0 else.

proc ::struct::tree::_exists {name node} {
    return [info exists ::struct::tree::tree${name}::parent($node)]
}

# ::struct::tree::_get --
#
#	Get a keyed value from a node in a tree.
#
# Arguments:
#	name	name of the tree.
#	node	node to query.
#	flag	-key; anything else is an error
#	key	key to lookup; defaults to data
#
# Results:
#	value	value associated with the key given.

proc ::struct::tree::_get {name node {flag -key} {key data}} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    
    upvar ::struct::tree::tree${name}::node${node} data
    if { ![info exists data($key)] } {
	error "invalid key \"$key\" for node \"$node\""
    }
    return $data($key)
}

# ::struct::tree::_insert --
#
#	Add a node to a tree.
#
# Arguments:
#	name		name of the tree.
#	parentNode	parent to add the node to.
#	index		index at which to insert.
#	node		node to insert; must be unique.
#
# Results:
#	None.

proc ::struct::tree::_insert {name parentNode index node} {
    if { [_exists $name $node] } {
	error "node \"$node\" already exists in tree \"$name\""
    }
    
    if { ![_exists $name $parentNode] } {
	error "parent node \"$parentNode\" does not exist in tree \"$name\""
    }

    upvar ::struct::tree::tree${name}::parent parent
    upvar ::struct::tree::tree${name}::children children
    upvar ::struct::tree::tree${name}::node${node} data
    
    # Set up the new node
    set parent($node) $parentNode
    set children($node) [list ]
    set data(data) ""

    # Add this node to its parent's children list
    set children($parentNode) [linsert $children($parentNode) $index $node]

    return
}

# ::struct::tree::_move --
#
#	Move a node (and all its subnodes) from where ever it is to a new
#	location in the tree.
#
# Arguments:
#	name		name of the tree
#	parentNode	parent to add the node to.
#	index		index at which to insert.
#	node		node to insert; must be unique.
#
# Results:
#	None.

proc ::struct::tree::_move {name parentNode index node} {
    if { [string equal $node "root"] } {
	error "cannot move root node"
    }

    # Can only move a node to a real location in the tree
    if { ![_exists $name $parentNode] } {
	error "parent node \"$parentNode\" does not exist in tree \"$name\""
    }

    # Can only move real nodes
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }

    # Cannot move a node to be a descendant
    upvar ::struct::tree::tree${name}::parent parent
    set ancestor $parentNode
    while { ![string equal $ancestor "root"] } {
	if { [string equal $ancestor $node] } {
	    error "node \"$node\" cannot be its own descendant"
	}
	set ancestor $parent($ancestor)
    }
    
    upvar ::struct::tree::tree${name}::children children
    
    # Remove this node from its parent's children list
    set oldParent $parent($node)
    set oldInd [lsearch -exact $children($oldParent) $node]
    set children($oldParent) [lreplace $children($oldParent) $oldInd $oldInd]

    # Update the nodes parent value
    set parent($node) $parentNode

    # Add this node to its parent's children list
    set children($parentNode) [linsert $children($parentNode) $index $node]

    return
}

# ::struct::tree::_parent --
#
#	Return the name of the parent node of a node in a tree.
#
# Arguments:
#	name	name of the tree.
#	node	node to look up.
#
# Results:
#	parent	parent of node $node

proc ::struct::tree::_parent {name node} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    return [set ::struct::tree::tree${name}::parent($node)]
}

# ::struct::tree::_set --
#
#	Set or get a value for a node in a tree.
#
# Arguments:
#	name	name of the tree.
#	node	node to modify or query.
#	args	?-key key? ?value?
#
# Results:
#	val	value associated with the given key of the given node

proc ::struct::tree::_set {name node args} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    upvar ::struct::tree::tree${name}::node$node data

    if { [llength $args] > 3 } {
	error "wrong # args: should be \"$name set $node ?-key key?\
		?value?\""
    }
    
    set key "data"
    set haveValue 0
    if { [llength $args] > 1 } {
	foreach {flag key} $args break
	if { ![string match "${flag}*" "-key"] } {
	    error "invalid option \"$flag\": should be key"
	}
	if { [llength $args] == 3 } {
	    set haveValue 1
	    set value [lindex $args end]
	}
    } elseif { [llength $args] == 1 } {
	set haveValue 1
	set value [lindex $args end]
    }

    if { $haveValue } {
	# Setting a value
	return [set data($key) $value]
    } else {
	# Getting a value
	if { ![info exists data($key)] } {
	    error "invalid key \"$key\" for node \"$node\""
	}
	return $data($key)
    }
}

# ::struct::tree::_size --
#
#	Return the number of descendants of a given node.  The default node
#	is the special root node.
#
# Arguments:
#	name	name of the tree.
#	node	node to start counting from (default is root).
#
# Results:
#	size	number of descendants of the node.

proc ::struct::tree::_size {name {node root}} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    
    # If the node is the root, we can do the cheap thing and just count the
    # number of nodes (excluding the root node) that we have in the tree with
    # array names
    if { [string equal $node "root"] } {
	set size [llength [array names ::struct::tree::tree${name}::parent]]
	return [expr {$size - 1}]
    }

    # Otherwise we have to do it the hard way and do a full tree search
    upvar ::struct::tree::tree${name}::children children
    set size 0
    set st [list ]
    foreach child $children($node) {
	lappend st $child
    }
    while { [llength $st] > 0 } {
	set node [lindex $st end]
	set st [lreplace $st end end]
	incr size
	foreach child $children($node) {
	    lappend st $child
	}
    }
    return $size
}

# ::struct::tree::_swap --
#
#	Swap two nodes in a tree.
#
# Arguments:
#	name	name of the tree.
#	node1	first node to swap.
#	node2	second node to swap.
#
# Results:
#	None.

proc ::struct::tree::_swap {name node1 node2} {
    # Can't swap the magic root node
    if { [string equal $node1 "root"] || [string equal $node2 "root"] } {
	error "cannot swap root node"
    }
    
    # Can only swap two real nodes
    if { ![_exists $name $node1] } {
	error "node \"$node1\" does not exist in tree \"$name\""
    }
    if { ![_exists $name $node2] } {
	error "node \"$node2\" does not exist in tree \"$name\""
    }

    # Can't swap a node with itself
    if { [string equal $node1 $node2] } {
	error "cannot swap node \"$node1\" with itself"
    }

    # Swapping nodes means swapping their labels and values
    upvar ::struct::tree::tree${name}::children children
    upvar ::struct::tree::tree${name}::parent parent
    upvar ::struct::tree::tree${name}::node${node1} node1Vals
    upvar ::struct::tree::tree${name}::node${node2} node2Vals

    set parent1 $parent($node1)
    set parent2 $parent($node2)

    # Replace node1 with node2 in node1's parent's children list, and
    # node2 with node1 in node2's parent's children list
    set i1 [lsearch -exact $children($parent1) $node1]
    set i2 [lsearch -exact $children($parent2) $node2]

    set children($parent1) [lreplace $children($parent1) $i1 $i1 $node2]
    set children($parent2) [lreplace $children($parent2) $i2 $i2 $node1]
    
    # Make node1 the parent of node2's children, and vis versa
    foreach child $children($node2) {
	set parent($child) $node1
    }
    foreach child $children($node1) {
	set parent($child) $node2
    }
    
    # Swap the children lists
    set children1 $children($node1)
    set children($node1) $children($node2)
    set children($node2) $children1

    if { [string equal $node1 $parent2] } {
	set parent($node1) $node2
	set parent($node2) $parent1
    } elseif { [string equal $node2 $parent1] } {
	set parent($node1) $parent2
	set parent($node2) $node1
    } else {
	set parent($node1) $parent2
	set parent($node2) $parent1
    }

    # Swap the values
    set value1 [array get node1Vals]
    unset node1Vals
    array set node1Vals [array get node2Vals]
    unset node2Vals
    array set node2Vals $value1

    return
}

# ::struct::tree::_unset --
#
#	Remove a keyed value from a node.
#
# Arguments:
#	name	name of the tree.
#	node	node to modify.
#	args	additional args: ?-key key?
#
# Results:
#	None.

proc ::struct::tree::_unset {name node {flag -key} {key data}} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    
    if { ![string match "${flag}*" "-key"] } {
	error "invalid option \"$flag\": should be \"$name unset\
		$node ?-key key?\""
    }

    upvar ::struct::tree::tree${name}::node${node} data
    if { [info exists data($key)] } {
	unset data($key)
    }
    return
}

# ::struct::tree::_walk --
#
#	Walk a tree using a pre-, post-, or in-order depth or breadth first
#	search. Pre-order DFS is the default.  At each node that is visited,
#	a command will be called with the name of the tree and the node.
#
# Arguments:
#	name	name of the tree.
#	node	node at which to start.
#	args	additional args: ?-type {bfs|dfs}? ?-order {pre|post|in}?
#		-command cmd
#
# Results:
#	None.

proc ::struct::tree::_walk {name node args} {
    set usage "$name walk $node ?-type {bfs|dfs}?\
		?-order {pre|post|in}? -command cmd\""

    if {[llength $args] > 6 || [llength $args] < 2} {
	error "wrong # args: should be \"$usage\""
    }

    # Set defaults
    set type dfs
    set order pre
    set cmd ""

    for {set i 0} {$i < [llength $args]} {incr i} {
	set flag [lindex $args $i]
	incr i
	if { $i >= [llength $args] } {
	    error "value for \"$flag\" missing: should be \"$usage\""
	}
	switch -glob -- $flag {
	    "-type" {
		set type [string tolower [lindex $args $i]]
	    }
	    "-order" {
		# TODO -- it's a large hassle to support all three kinds 
		# of traversal here, so for now order is always pre-order.
		# To re-enable it, uncomment the next line and add support.
		#set order [string tolower [lindex $args $i]]
	    }
	    "-command" {
		set cmd [lindex $args $i]
	    }
	    default {
		error "unknown option \"$flag\": should be \"$usage\""
	    }
	}
    }
    
    # Make sure we have a command to run, otherwise what's the point?
    if { [string equal $cmd ""] } {
	error "no command specified: should be \"$usage\""
    }

    # Validate that the given type is good
    switch -glob -- $type {
	"dfs" {
	    set type "dfs"
	}
	"bfs" {
	    set type "bfs"
	}
	default {
	    error "invalid search type \"$type\": should be dfs, or bfs"
	}
    }
    
    # Validate that the given order is good
    switch -glob -- $order {
	"pre" {
	    set order pre
	}
	"post" {
	    set order post
	}
	"in" {
	    set order in
	}
	default {
	    error "invalid search order \"$order\": should be pre, post, or in"
	}
    }

    # Do the walk
    upvar ::struct::tree::tree${name}::children children
    set st [list ]
    lappend st $node
    if { [string equal $type "dfs"] } {
	# Depth-first search
	while { [llength $st] > 0 } {
	    set node [lindex $st end]
	    set st [lreplace $st end end]
	    # Evaluate the command at this node
	    set cmdcpy $cmd
	    lappend cmdcpy $name $node
	    uplevel 2 $cmdcpy
	    
	    # Add this node's children.  Have to add them in reverse order
	    # so that they will be popped left-to-right
	    set len [llength $children($node)]
	    for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} {
		lappend st [lindex $children($node) $i]
	    }
	}
    } else {
	# Breadth first search
	while { [llength $st] > 0 } {
	    set node [lindex $st 0]
	    set st [lreplace $st 0 0]
	    # Evaluate the command at this node
	    set cmdcpy $cmd
	    lappend cmdcpy $name $node
	    uplevel 2 $cmdcpy
	    
	    # Add this node's children
	    foreach child $children($node) {
		lappend st $child
	    }
	}
    }
    return
}

Added modules/struct/tree.test.


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
# tree.test:  tests for the tree structure.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-2000 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: tree.test,v 1.1.1.1 2000/02/24 17:44:43 ericm Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require struct
namespace import struct::*

test tree-0.1 {tree errors} {
    tree mytree
    catch {tree mytree} msg
    mytree destroy
    set msg
} "command \"mytree\" already exists, unable to create tree"
test tree-0.2 {tree errors} {
    tree mytree
    catch {mytree} msg
    mytree destroy
    set msg
} "wrong # args: should be \"mytree option ?arg arg ...?\""
test tree-0.3 {tree errors} {
    tree mytree
    catch {mytree foo} msg
    mytree destroy
    set msg
} "bad option \"foo\": must be children, destroy, delete, depth, exists, get, insert, move, parent, set, size, swap, unset, or walk"
test tree-0.4 {tree errors} {
    catch {tree set} msg
    set msg
} "command \"set\" already exists, unable to create tree"

test tree-1.1 {children} {
    tree mytree
    set result [list ]
    lappend result [mytree children root]
    mytree insert root end node0
    mytree insert root end node1
    mytree insert root end node2
    mytree insert node0 end node3
    mytree insert node0 end node4
    lappend result [mytree children root]
    lappend result [mytree children node0]
    mytree destroy
    set result
} [list {} {node0 node1 node2} {node3 node4}]

test tree-2.1 {create} {
    tree mytree
    set result [string equal [info commands ::mytree] "::mytree"]
    mytree destroy
    set result
} 1
test tree-2.2 {create} {
    set name [tree]
    set result [list $name [string equal [info commands ::$name] "::$name"]]
    $name destroy
    set result
} [list tree1 1]

test tree-3.1 {destroy} {
    tree mytree
    mytree destroy
    string equal [info commands ::mytree] ""
} 1

test tree-4.1 {delete} {
    tree mytree
    catch {mytree delete root} msg
    mytree destroy
    set msg
} "cannot delete root node"
test tree-4.2 {delete} {
    tree mytree
    catch {mytree delete node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-4.3 {delete} {
    tree mytree
    mytree insert root end node0
    mytree delete node0
    set result [list [mytree exists node0] [mytree children root]]
    mytree destroy
    set result
} {0 {}}
test tree-4.4 {delete} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node1
    mytree insert node1 end node2
    mytree delete node0
    set result [list [mytree exists node0] \
	    [mytree exists node1] \
	    [mytree exists node2]]
    mytree destroy
    set result
} {0 0 0}

test tree-5.1 {exists} {
    tree mytree
    set result [list ]
    lappend result [mytree exists root]
    mytree insert root end node0
    lappend result [mytree exists node0]
    mytree delete node0
    lappend result [mytree exists node0]
    mytree destroy
    set result
} {1 1 0}

test tree-6.1 {insert gives error on duplicate node name} {
    tree mytree
    mytree insert root end node0
    catch {mytree insert root end node0} msg
    mytree destroy
    set msg
} "node \"node0\" already exists in tree \"mytree\""
test tree-6.2 {insert creates and initializes node} {
    tree mytree
    mytree insert root end node0
    set result [list ]
    lappend result [mytree exists node0]
    lappend result [mytree parent node0]
    lappend result [mytree children node0]
    lappend result [mytree set node0]
    lappend result [mytree children root]
    mytree destroy
    set result
} {1 root {} {} node0}
test tree-6.3 {insert insert nodes in correct location} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1
    mytree insert root 0 node2
    set result [mytree children root]
    mytree destroy
    set result
} {node2 node0 node1}
test tree-6.4 {insert gives error when trying to insert to a fake parent} {
    tree mytree
    catch {mytree insert node0 end node1} msg
    mytree destroy
    set msg
} "parent node \"node0\" does not exist in tree \"mytree\""

test tree-7.1 {move gives error when trying to move root} {
    tree mytree
    mytree insert root end node0
    catch {mytree move node0 end root} msg
    mytree destroy
    set msg
} "cannot move root node"
test tree-7.2 {move gives error when trying to move non existant node} {
    tree mytree
    catch {mytree move root end node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-7.3 {move gives error when trying to move to non existant parent} {
    tree mytree
    catch {mytree move node0 end node0} msg
    mytree destroy
    set msg
} "parent node \"node0\" does not exist in tree \"mytree\""
test tree-7.4 {move gives error when trying to make node its own descendant} {
    tree mytree
    mytree insert root end node0
    catch {mytree move node0 end node0} msg
    mytree destroy
    set msg
} "node \"node0\" cannot be its own descendant"
test tree-7.5 {move gives error when trying to make node its own descendant} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node1
    mytree insert node1 end node2
    catch {mytree move node2 end node0} msg
    mytree destroy
    set msg
} "node \"node0\" cannot be its own descendant"
test tree-7.6 {move correctly moves a node} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node1
    mytree insert node1 end node2
    mytree move node0 end node2
    set result [list [mytree children node0] [mytree children node1]]
    lappend result [mytree parent node2]
    mytree destroy
    set result
} {{node1 node2} {} node0}

test tree-8.1 {parent gives error on fake node} {
    tree mytree
    catch {mytree parent node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-8.2 {parent gives correct value} {
    tree mytree
    mytree insert root end node0
    set result [list [mytree parent node0] [mytree parent root]]
    mytree destroy
    set result
} {root {}}

test tree-9.1 {size gives error on bogus node} {
    tree mytree
    catch {mytree size node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-9.2 {size uses root node as default} {
    tree mytree
    set result [mytree size]
    mytree destroy
    set result
} 0
test tree-9.3 {size gives correct value} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1
    mytree insert root end node2
    mytree insert root end node3
    mytree insert root end node4
    mytree insert root end node5
    set result [mytree size]
    mytree destroy
    set result
} 6
test tree-9.4 {size gives correct value} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node1
    mytree insert node0 end node2
    mytree insert node0 end node3
    mytree insert node1 end node4
    mytree insert node1 end node5
    set result [mytree size node0]
    mytree destroy
    set result
} 5
test tree-9.5 {size gives correct value} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node1
    mytree insert node0 end node2
    mytree insert node0 end node3
    mytree insert node1 end node4
    mytree insert node1 end node5
    set result [mytree size node1]
    mytree destroy
    set result
} 2

test tree-10.1 {set gives error on bogus node} {
    tree mytree
    catch {mytree set node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-10.2 {set with node name gets/sets "data" value} {
    tree mytree
    mytree insert root end node0
    mytree set node0 foobar
    set result [mytree set node0]
    mytree destroy
    set result
} "foobar"
test tree-10.3 {set with node name and key gets/sets key value} {
    tree mytree
    mytree insert root end node0
    mytree set node0 -key baz foobar
    set result [list [mytree set node0] [mytree set node0 -key baz]]
    mytree destroy
    set result
} [list "" "foobar"]
test tree-10.4 {set with too many args gives error} {
    tree mytree
    mytree insert root end node0
    catch {mytree set node0 foo bar baz boo} msg
    mytree destroy
    set msg
} "wrong # args: should be \"mytree set node0 ?-key key? ?value?\""
test tree-10.5 {set with bad args} {
    tree mytree
    mytree insert root end node0
    catch {mytree set node0 foo bar} msg
    mytree destroy
    set msg
} "invalid option \"foo\": should be key"
test tree-10.6 {set with bad args} {
    tree mytree
    mytree insert root end node0
    catch {mytree set node0 foo bar baz} msg
    mytree destroy
    set msg
} "invalid option \"foo\": should be key"
test tree-10.7 {set with bad key gives error} {
    tree mytree
    mytree insert root end node0
    catch {mytree set node0 -key foo} msg
    mytree destroy
    set msg
} "invalid key \"foo\" for node \"node0\""

test tree-11.1 {depth} {
    tree mytree
    catch {mytree depth node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-11.2 {depth of root is 0} {
    tree mytree
    set result [mytree depth root]
    mytree destroy
    set result
} 0
test tree-11.2 {depth is computed correctly} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node1
    mytree insert node1 end node2
    mytree insert node2 end node3
    set result [mytree depth node3]
    mytree destroy
    set result
} 4

test tree-12.1 {dfs walk} {
    tree mytree
    set t [list ]
    mytree insert root end node0
    mytree insert root end node1
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree walk root -type dfs -command {lappend t}
    mytree destroy
    set t
} [list mytree root mytree node0 mytree node0.1 mytree node0.2 mytree node1 \
	mytree node1.1 mytree node1.2]
test tree-12.2 {bfs walk} {
    tree mytree
    set t [list ]
    mytree insert root end node0
    mytree insert root end node1
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree walk root -type bfs -command {lappend t}
    mytree destroy
    set t
} [list mytree root mytree node0 mytree node1 mytree node0.1 mytree node0.2 \
	mytree node1.1 mytree node1.2]
test tree-12.3 {dfs is default walk} {
    tree mytree
    set t [list ]
    mytree insert root end node0
    mytree insert root end node1
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree walk root -command {lappend t}
    mytree destroy
    set t
} [list mytree root mytree node0 mytree node0.1 mytree node0.2 mytree node1 \
	mytree node1.1 mytree node1.2]

test tree-13.1 {swap gives error when trying to swap root} {
    tree mytree
    catch {mytree swap root node0} msg
    mytree destroy
    set msg
} "cannot swap root node"
test tree-13.2 {swap gives error when trying to swap non existant node} {
    tree mytree
    catch {mytree swap node0 node1} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-13.3 {swap gives error when trying to swap non existant node} {
    tree mytree
    mytree insert root end node0
    catch {mytree swap node0 node1} msg
    mytree destroy
    set msg
} "node \"node1\" does not exist in tree \"mytree\""
test tree-13.3 {swap gives error when trying to swap node with self} {
    tree mytree
    mytree insert root end node0
    catch {mytree swap node0 node0} msg
    mytree destroy
    set msg
} "cannot swap node \"node0\" with itself"
test tree-13.4 {swap swaps node relationships correctly} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node0.1 end node0.1.1
    mytree insert node0.1 end node0.1.2
    mytree swap node0 node0.1
    set t [list ]
    mytree walk root -command {lappend t}
    mytree destroy
    set t
} [list mytree root mytree node0.1 mytree node0 mytree node0.1.1 \
	mytree node0.1.2 mytree node0.2]
test tree-13.5 {swap swaps node relationships correctly} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node0.1 end node0.1.1
    mytree insert node0.1 end node0.1.2
    mytree swap node0 node0.1.1
    set t [list ]
    mytree walk root -command {lappend t}
    mytree destroy
    set t
} [list mytree root mytree node0.1.1 mytree node0.1 mytree node0 \
	mytree node0.1.2 mytree node0.2]
test tree-13.6 {swap swaps node relationships correctly} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1
    mytree insert node0 end node0.1
    mytree insert node1 end node1.1
    mytree swap node0 node1
    set t [list ]
    mytree walk root -command {lappend t}
    mytree destroy
    set t
} [list mytree root mytree node1 mytree node0.1 mytree node0 \
	mytree node1.1]

test tree-14.1 {get gives error on bogus node} {
    tree mytree
    catch {mytree get node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-14.2 {get gives error on bogus key} {
    tree mytree
    mytree insert root end node0
    catch {mytree get node0 -key bogus} msg
    mytree destroy
    set msg
} "invalid key \"bogus\" for node \"node0\""
test tree-14.2 {get uses data as default key} {
    tree mytree
    mytree insert root end node0
    mytree set node0 foobar
    set result [mytree get node0]
    mytree destroy
    set result
} "foobar"
test tree-14.3 {get respects -key flag} {
    tree mytree
    mytree insert root end node0
    mytree set node0 -key boom foobar
    set result [mytree get node0 -key boom]
    mytree destroy
    set result
} "foobar"

test tree-15.1 {unset gives error on bogus node} {
    tree mytree
    catch {mytree unset node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-15.2 {unset does not give error on bogus key} {
    tree mytree
    mytree insert root end node0
    set result [catch {mytree unset node0 -key bogus}]
    mytree destroy
    set result
} 0
test tree-15.3 {unset removes a keyed value from a node} {
    tree mytree
    mytree insert root end node0
    mytree set node0 -key foobar foobar
    mytree unset node0 -key foobar
    catch {mytree get node0 -key foobar} msg
    mytree destroy
    set msg
} "invalid key \"foobar\" for node \"node0\""

::tcltest::cleanupTests