Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch tcllib-vendor-branch Excluding Merge-Ins
This is equivalent to a diff from ca03628808 to e4a05cae84
2003-07-01
| ||
11:03 | initial version Closed-Leaf check-in: 13fda2e2de user: afaupell tags: vendor | |
2000-02-24
| ||
17:44 | tcllib re-import check-in: 1e5676677b user: ericm tags: trunk | |
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 | |
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 |