ADDED ChangeLog Index: ChangeLog ================================================================== --- /dev/null +++ ChangeLog @@ -0,0 +1,11 @@ +2000-02-17 Eric Melski + + * 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 Index: modules/profiler/man.macros ================================================================== --- /dev/null +++ modules/profiler/man.macros @@ -0,0 +1,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 Index: modules/profiler/pkgIndex.tcl ================================================================== --- /dev/null +++ modules/profiler/pkgIndex.tcl @@ -0,0 +1,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 Index: modules/profiler/profiler.n ================================================================== --- /dev/null +++ modules/profiler/profiler.n @@ -0,0 +1,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 Index: modules/profiler/profiler.tcl ================================================================== --- /dev/null +++ modules/profiler/profiler.tcl @@ -0,0 +1,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 Index: modules/profiler/profiler.test ================================================================== --- /dev/null +++ modules/profiler/profiler.test @@ -0,0 +1,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 Index: modules/struct/man.macros ================================================================== --- /dev/null +++ modules/struct/man.macros @@ -0,0 +1,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 Index: modules/struct/pkgIndex.tcl ================================================================== --- /dev/null +++ modules/struct/pkgIndex.tcl @@ -0,0 +1,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 Index: modules/struct/queue.n ================================================================== --- /dev/null +++ modules/struct/queue.n @@ -0,0 +1,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 Index: modules/struct/queue.tcl ================================================================== --- /dev/null +++ modules/struct/queue.tcl @@ -0,0 +1,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 Index: modules/struct/queue.test ================================================================== --- /dev/null +++ modules/struct/queue.test @@ -0,0 +1,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 Index: modules/struct/stack.n ================================================================== --- /dev/null +++ modules/struct/stack.n @@ -0,0 +1,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 Index: modules/struct/stack.tcl ================================================================== --- /dev/null +++ modules/struct/stack.tcl @@ -0,0 +1,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 Index: modules/struct/stack.test ================================================================== --- /dev/null +++ modules/struct/stack.test @@ -0,0 +1,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 Index: modules/struct/struct.tcl ================================================================== --- /dev/null +++ modules/struct/struct.tcl @@ -0,0 +1,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 Index: modules/struct/tree.n ================================================================== --- /dev/null +++ modules/struct/tree.n @@ -0,0 +1,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 Index: modules/struct/tree.tcl ================================================================== --- /dev/null +++ modules/struct/tree.tcl @@ -0,0 +1,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 Index: modules/struct/tree.test ================================================================== --- /dev/null +++ modules/struct/tree.test @@ -0,0 +1,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