| 1 | # auto.tcl -- |
| 2 | # |
| 3 | # utility procs formerly in init.tcl dealing with auto execution |
| 4 | # of commands and can be auto loaded themselves. |
| 5 | # |
| 6 | # RCS: @(#) $Id: auto.tcl,v 1.12.2.8 2005/06/27 18:20:26 dgp Exp $ |
| 7 | # |
| 8 | # Copyright (c) 1991-1993 The Regents of the University of California. |
| 9 | # Copyright (c) 1994-1998 Sun Microsystems, Inc. |
| 10 | # |
| 11 | # See the file "license.terms" for information on usage and redistribution |
| 12 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
| 13 | # |
| 14 | |
| 15 | # auto_reset -- |
| 16 | # |
| 17 | # Destroy all cached information for auto-loading and auto-execution, |
| 18 | # so that the information gets recomputed the next time it's needed. |
| 19 | # Also delete any procedures that are listed in the auto-load index |
| 20 | # except those defined in this file. |
| 21 | # |
| 22 | # Arguments: |
| 23 | # None. |
| 24 | |
| 25 | proc auto_reset {} { |
| 26 | global auto_execs auto_index auto_oldpath |
| 27 | foreach p [info procs] { |
| 28 | if {[info exists auto_index($p)] && ![string match auto_* $p] |
| 29 | && ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup |
| 30 | tcl_findLibrary pkg_compareExtension |
| 31 | tclPkgUnknown tcl::MacOSXPkgUnknown |
| 32 | tcl::MacPkgUnknown} $p] < 0)} { |
| 33 | rename $p {} |
| 34 | } |
| 35 | } |
| 36 | catch {unset auto_execs} |
| 37 | catch {unset auto_index} |
| 38 | catch {unset auto_oldpath} |
| 39 | } |
| 40 | |
| 41 | # tcl_findLibrary -- |
| 42 | # |
| 43 | # This is a utility for extensions that searches for a library directory |
| 44 | # using a canonical searching algorithm. A side effect is to source |
| 45 | # the initialization script and set a global library variable. |
| 46 | # |
| 47 | # Arguments: |
| 48 | # basename Prefix of the directory name, (e.g., "tk") |
| 49 | # version Version number of the package, (e.g., "8.0") |
| 50 | # patch Patchlevel of the package, (e.g., "8.0.3") |
| 51 | # initScript Initialization script to source (e.g., tk.tcl) |
| 52 | # enVarName environment variable to honor (e.g., TK_LIBRARY) |
| 53 | # varName Global variable to set when done (e.g., tk_library) |
| 54 | |
| 55 | proc tcl_findLibrary {basename version patch initScript enVarName varName} { |
| 56 | upvar #0 $varName the_library |
| 57 | global env errorInfo |
| 58 | |
| 59 | set dirs {} |
| 60 | set errors {} |
| 61 | |
| 62 | # The C application may have hardwired a path, which we honor |
| 63 | |
| 64 | set variableSet [info exists the_library] |
| 65 | if {$variableSet && $the_library ne ""} { |
| 66 | lappend dirs $the_library |
| 67 | } else { |
| 68 | |
| 69 | # Do the canonical search |
| 70 | |
| 71 | # 1. From an environment variable, if it exists. |
| 72 | # Placing this first gives the end-user ultimate control |
| 73 | # to work-around any bugs, or to customize. |
| 74 | |
| 75 | if {[info exists env($enVarName)]} { |
| 76 | lappend dirs $env($enVarName) |
| 77 | } |
| 78 | |
| 79 | # 2. In the package script directory registered within |
| 80 | # the configuration of the package itself. |
| 81 | # |
| 82 | # Only do this for Tcl 8.5+, when Tcl_RegsiterConfig() is available. |
| 83 | #if {[catch { |
| 84 | # ::${basename}::pkgconfig get scriptdir,runtime |
| 85 | #} value] == 0} { |
| 86 | # lappend dirs $value |
| 87 | #} |
| 88 | |
| 89 | # 3. Relative to auto_path directories. This checks relative to the |
| 90 | # Tcl library as well as allowing loading of libraries added to the |
| 91 | # auto_path that is not relative to the core library or binary paths. |
| 92 | foreach d $::auto_path { |
| 93 | lappend dirs [file join $d $basename$version] |
| 94 | if {$::tcl_platform(platform) eq "unix" |
| 95 | && $::tcl_platform(os) eq "Darwin"} { |
| 96 | # 4. On MacOSX, check the Resources/Scripts subdir too |
| 97 | lappend dirs [file join $d $basename$version Resources Scripts] |
| 98 | } |
| 99 | } |
| 100 | |
| 101 | # 3. Various locations relative to the executable |
| 102 | # ../lib/foo1.0 (From bin directory in install hierarchy) |
| 103 | # ../../lib/foo1.0 (From bin/arch directory in install hierarchy) |
| 104 | # ../library (From unix directory in build hierarchy) |
| 105 | set parentDir [file dirname [file dirname [info nameofexecutable]]] |
| 106 | set grandParentDir [file dirname $parentDir] |
| 107 | lappend dirs [file join $parentDir lib $basename$version] |
| 108 | lappend dirs [file join $grandParentDir lib $basename$version] |
| 109 | lappend dirs [file join $parentDir library] |
| 110 | |
| 111 | # Remaining locations are out of date (when relevant, they ought |
| 112 | # to be covered by the $::auto_path seach above). |
| 113 | # |
| 114 | # ../../library (From unix/arch directory in build hierarchy) |
| 115 | # ../../foo1.0.1/library |
| 116 | # (From unix directory in parallel build hierarchy) |
| 117 | # ../../../foo1.0.1/library |
| 118 | # (From unix/arch directory in parallel build hierarchy) |
| 119 | # |
| 120 | # For the sake of extra compatibility safety, we keep adding these |
| 121 | # paths during the 8.4.* release series. |
| 122 | if {1} { |
| 123 | lappend dirs [file join $grandParentDir library] |
| 124 | lappend dirs [file join $grandParentDir $basename$patch library] |
| 125 | lappend dirs [file join [file dirname $grandParentDir] \ |
| 126 | $basename$patch library] |
| 127 | } |
| 128 | } |
| 129 | # uniquify $dirs in order |
| 130 | array set seen {} |
| 131 | foreach i $dirs { |
| 132 | # For Tcl 8.4.9, we've disabled the use of [file normalize] here. |
| 133 | # This means that two different path names that are the same path |
| 134 | # in normalized form, will both remain on the search path. There |
| 135 | # should be no harm in that, just a bit more file system access |
| 136 | # than is strictly necessary. |
| 137 | # |
| 138 | # [file normalize] has been disabled because of reports it has |
| 139 | # caused difficulties with the freewrap utility. To keep |
| 140 | # compatibility with freewrap's needs, we'll keep this disabled |
| 141 | # throughout the 8.4.x (x >= 9) releases. See Bug 1072136. |
| 142 | if {1 || [interp issafe]} { |
| 143 | set norm $i |
| 144 | } else { |
| 145 | set norm [file normalize $i] |
| 146 | } |
| 147 | if {[info exists seen($norm)]} { continue } |
| 148 | set seen($norm) "" |
| 149 | lappend uniqdirs $i |
| 150 | } |
| 151 | set dirs $uniqdirs |
| 152 | foreach i $dirs { |
| 153 | set the_library $i |
| 154 | set file [file join $i $initScript] |
| 155 | |
| 156 | # source everything when in a safe interpreter because |
| 157 | # we have a source command, but no file exists command |
| 158 | |
| 159 | if {[interp issafe] || [file exists $file]} { |
| 160 | if {![catch {uplevel #0 [list source $file]} msg]} { |
| 161 | return |
| 162 | } else { |
| 163 | append errors "$file: $msg\n$errorInfo\n" |
| 164 | } |
| 165 | } |
| 166 | } |
| 167 | if {!$variableSet} { |
| 168 | unset the_library |
| 169 | } |
| 170 | set msg "Can't find a usable $initScript in the following directories: \n" |
| 171 | append msg " $dirs\n\n" |
| 172 | append msg "$errors\n\n" |
| 173 | append msg "This probably means that $basename wasn't installed properly.\n" |
| 174 | error $msg |
| 175 | } |
| 176 | |
| 177 | |
| 178 | # ---------------------------------------------------------------------- |
| 179 | # auto_mkindex |
| 180 | # ---------------------------------------------------------------------- |
| 181 | # The following procedures are used to generate the tclIndex file |
| 182 | # from Tcl source files. They use a special safe interpreter to |
| 183 | # parse Tcl source files, writing out index entries as "proc" |
| 184 | # commands are encountered. This implementation won't work in a |
| 185 | # safe interpreter, since a safe interpreter can't create the |
| 186 | # special parser and mess with its commands. |
| 187 | |
| 188 | if {[interp issafe]} { |
| 189 | return ;# Stop sourcing the file here |
| 190 | } |
| 191 | |
| 192 | # auto_mkindex -- |
| 193 | # Regenerate a tclIndex file from Tcl source files. Takes as argument |
| 194 | # the name of the directory in which the tclIndex file is to be placed, |
| 195 | # followed by any number of glob patterns to use in that directory to |
| 196 | # locate all of the relevant files. |
| 197 | # |
| 198 | # Arguments: |
| 199 | # dir - Name of the directory in which to create an index. |
| 200 | # args - Any number of additional arguments giving the |
| 201 | # names of files within dir. If no additional |
| 202 | # are given auto_mkindex will look for *.tcl. |
| 203 | |
| 204 | proc auto_mkindex {dir args} { |
| 205 | global errorCode errorInfo |
| 206 | |
| 207 | if {[interp issafe]} { |
| 208 | error "can't generate index within safe interpreter" |
| 209 | } |
| 210 | |
| 211 | set oldDir [pwd] |
| 212 | cd $dir |
| 213 | set dir [pwd] |
| 214 | |
| 215 | append index "# Tcl autoload index file, version 2.0\n" |
| 216 | append index "# This file is generated by the \"auto_mkindex\" command\n" |
| 217 | append index "# and sourced to set up indexing information for one or\n" |
| 218 | append index "# more commands. Typically each line is a command that\n" |
| 219 | append index "# sets an element in the auto_index array, where the\n" |
| 220 | append index "# element name is the name of a command and the value is\n" |
| 221 | append index "# a script that loads the command.\n\n" |
| 222 | if {$args == ""} { |
| 223 | set args *.tcl |
| 224 | } |
| 225 | |
| 226 | auto_mkindex_parser::init |
| 227 | foreach file [eval glob $args] { |
| 228 | if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} { |
| 229 | append index $msg |
| 230 | } else { |
| 231 | set code $errorCode |
| 232 | set info $errorInfo |
| 233 | cd $oldDir |
| 234 | error $msg $info $code |
| 235 | } |
| 236 | } |
| 237 | auto_mkindex_parser::cleanup |
| 238 | |
| 239 | set fid [open "tclIndex" w] |
| 240 | puts -nonewline $fid $index |
| 241 | close $fid |
| 242 | cd $oldDir |
| 243 | } |
| 244 | |
| 245 | # Original version of auto_mkindex that just searches the source |
| 246 | # code for "proc" at the beginning of the line. |
| 247 | |
| 248 | proc auto_mkindex_old {dir args} { |
| 249 | global errorCode errorInfo |
| 250 | set oldDir [pwd] |
| 251 | cd $dir |
| 252 | set dir [pwd] |
| 253 | append index "# Tcl autoload index file, version 2.0\n" |
| 254 | append index "# This file is generated by the \"auto_mkindex\" command\n" |
| 255 | append index "# and sourced to set up indexing information for one or\n" |
| 256 | append index "# more commands. Typically each line is a command that\n" |
| 257 | append index "# sets an element in the auto_index array, where the\n" |
| 258 | append index "# element name is the name of a command and the value is\n" |
| 259 | append index "# a script that loads the command.\n\n" |
| 260 | if {[string equal $args ""]} { |
| 261 | set args *.tcl |
| 262 | } |
| 263 | foreach file [eval glob $args] { |
| 264 | set f "" |
| 265 | set error [catch { |
| 266 | set f [open $file] |
| 267 | while {[gets $f line] >= 0} { |
| 268 | if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} { |
| 269 | set procName [lindex [auto_qualify $procName "::"] 0] |
| 270 | append index "set [list auto_index($procName)]" |
| 271 | append index " \[list source \[file join \$dir [list $file]\]\]\n" |
| 272 | } |
| 273 | } |
| 274 | close $f |
| 275 | } msg] |
| 276 | if {$error} { |
| 277 | set code $errorCode |
| 278 | set info $errorInfo |
| 279 | catch {close $f} |
| 280 | cd $oldDir |
| 281 | error $msg $info $code |
| 282 | } |
| 283 | } |
| 284 | set f "" |
| 285 | set error [catch { |
| 286 | set f [open tclIndex w] |
| 287 | puts -nonewline $f $index |
| 288 | close $f |
| 289 | cd $oldDir |
| 290 | } msg] |
| 291 | if {$error} { |
| 292 | set code $errorCode |
| 293 | set info $errorInfo |
| 294 | catch {close $f} |
| 295 | cd $oldDir |
| 296 | error $msg $info $code |
| 297 | } |
| 298 | } |
| 299 | |
| 300 | # Create a safe interpreter that can be used to parse Tcl source files |
| 301 | # generate a tclIndex file for autoloading. This interp contains |
| 302 | # commands for things that need index entries. Each time a command |
| 303 | # is executed, it writes an entry out to the index file. |
| 304 | |
| 305 | namespace eval auto_mkindex_parser { |
| 306 | variable parser "" ;# parser used to build index |
| 307 | variable index "" ;# maintains index as it is built |
| 308 | variable scriptFile "" ;# name of file being processed |
| 309 | variable contextStack "" ;# stack of namespace scopes |
| 310 | variable imports "" ;# keeps track of all imported cmds |
| 311 | variable initCommands "" ;# list of commands that create aliases |
| 312 | |
| 313 | proc init {} { |
| 314 | variable parser |
| 315 | variable initCommands |
| 316 | |
| 317 | if {![interp issafe]} { |
| 318 | set parser [interp create -safe] |
| 319 | $parser hide info |
| 320 | $parser hide rename |
| 321 | $parser hide proc |
| 322 | $parser hide namespace |
| 323 | $parser hide eval |
| 324 | $parser hide puts |
| 325 | $parser invokehidden namespace delete :: |
| 326 | $parser invokehidden proc unknown {args} {} |
| 327 | |
| 328 | # We'll need access to the "namespace" command within the |
| 329 | # interp. Put it back, but move it out of the way. |
| 330 | |
| 331 | $parser expose namespace |
| 332 | $parser invokehidden rename namespace _%@namespace |
| 333 | $parser expose eval |
| 334 | $parser invokehidden rename eval _%@eval |
| 335 | |
| 336 | # Install all the registered psuedo-command implementations |
| 337 | |
| 338 | foreach cmd $initCommands { |
| 339 | eval $cmd |
| 340 | } |
| 341 | } |
| 342 | } |
| 343 | proc cleanup {} { |
| 344 | variable parser |
| 345 | interp delete $parser |
| 346 | unset parser |
| 347 | } |
| 348 | } |
| 349 | |
| 350 | # auto_mkindex_parser::mkindex -- |
| 351 | # |
| 352 | # Used by the "auto_mkindex" command to create a "tclIndex" file for |
| 353 | # the given Tcl source file. Executes the commands in the file, and |
| 354 | # handles things like the "proc" command by adding an entry for the |
| 355 | # index file. Returns a string that represents the index file. |
| 356 | # |
| 357 | # Arguments: |
| 358 | # file Name of Tcl source file to be indexed. |
| 359 | |
| 360 | proc auto_mkindex_parser::mkindex {file} { |
| 361 | variable parser |
| 362 | variable index |
| 363 | variable scriptFile |
| 364 | variable contextStack |
| 365 | variable imports |
| 366 | |
| 367 | set scriptFile $file |
| 368 | |
| 369 | set fid [open $file] |
| 370 | set contents [read $fid] |
| 371 | close $fid |
| 372 | |
| 373 | # There is one problem with sourcing files into the safe |
| 374 | # interpreter: references like "$x" will fail since code is not |
| 375 | # really being executed and variables do not really exist. |
| 376 | # To avoid this, we replace all $ with \0 (literally, the null char) |
| 377 | # later, when getting proc names we will have to reverse this replacement, |
| 378 | # in case there were any $ in the proc name. This will cause a problem |
| 379 | # if somebody actually tries to have a \0 in their proc name. Too bad |
| 380 | # for them. |
| 381 | regsub -all {\$} $contents "\0" contents |
| 382 | |
| 383 | set index "" |
| 384 | set contextStack "" |
| 385 | set imports "" |
| 386 | |
| 387 | $parser eval $contents |
| 388 | |
| 389 | foreach name $imports { |
| 390 | catch {$parser eval [list _%@namespace forget $name]} |
| 391 | } |
| 392 | return $index |
| 393 | } |
| 394 | |
| 395 | # auto_mkindex_parser::hook command |
| 396 | # |
| 397 | # Registers a Tcl command to evaluate when initializing the |
| 398 | # slave interpreter used by the mkindex parser. |
| 399 | # The command is evaluated in the master interpreter, and can |
| 400 | # use the variable auto_mkindex_parser::parser to get to the slave |
| 401 | |
| 402 | proc auto_mkindex_parser::hook {cmd} { |
| 403 | variable initCommands |
| 404 | |
| 405 | lappend initCommands $cmd |
| 406 | } |
| 407 | |
| 408 | # auto_mkindex_parser::slavehook command |
| 409 | # |
| 410 | # Registers a Tcl command to evaluate when initializing the |
| 411 | # slave interpreter used by the mkindex parser. |
| 412 | # The command is evaluated in the slave interpreter. |
| 413 | |
| 414 | proc auto_mkindex_parser::slavehook {cmd} { |
| 415 | variable initCommands |
| 416 | |
| 417 | # The $parser variable is defined to be the name of the |
| 418 | # slave interpreter when this command is used later. |
| 419 | |
| 420 | lappend initCommands "\$parser eval [list $cmd]" |
| 421 | } |
| 422 | |
| 423 | # auto_mkindex_parser::command -- |
| 424 | # |
| 425 | # Registers a new command with the "auto_mkindex_parser" interpreter |
| 426 | # that parses Tcl files. These commands are fake versions of things |
| 427 | # like the "proc" command. When you execute them, they simply write |
| 428 | # out an entry to a "tclIndex" file for auto-loading. |
| 429 | # |
| 430 | # This procedure allows extensions to register their own commands |
| 431 | # with the auto_mkindex facility. For example, a package like |
| 432 | # [incr Tcl] might register a "class" command so that class definitions |
| 433 | # could be added to a "tclIndex" file for auto-loading. |
| 434 | # |
| 435 | # Arguments: |
| 436 | # name Name of command recognized in Tcl files. |
| 437 | # arglist Argument list for command. |
| 438 | # body Implementation of command to handle indexing. |
| 439 | |
| 440 | proc auto_mkindex_parser::command {name arglist body} { |
| 441 | hook [list auto_mkindex_parser::commandInit $name $arglist $body] |
| 442 | } |
| 443 | |
| 444 | # auto_mkindex_parser::commandInit -- |
| 445 | # |
| 446 | # This does the actual work set up by auto_mkindex_parser::command |
| 447 | # This is called when the interpreter used by the parser is created. |
| 448 | # |
| 449 | # Arguments: |
| 450 | # name Name of command recognized in Tcl files. |
| 451 | # arglist Argument list for command. |
| 452 | # body Implementation of command to handle indexing. |
| 453 | |
| 454 | proc auto_mkindex_parser::commandInit {name arglist body} { |
| 455 | variable parser |
| 456 | |
| 457 | set ns [namespace qualifiers $name] |
| 458 | set tail [namespace tail $name] |
| 459 | if {[string equal $ns ""]} { |
| 460 | set fakeName "[namespace current]::_%@fake_$tail" |
| 461 | } else { |
| 462 | set fakeName "_%@fake_$name" |
| 463 | regsub -all {::} $fakeName "_" fakeName |
| 464 | set fakeName "[namespace current]::$fakeName" |
| 465 | } |
| 466 | proc $fakeName $arglist $body |
| 467 | |
| 468 | # YUK! Tcl won't let us alias fully qualified command names, |
| 469 | # so we can't handle names like "::itcl::class". Instead, |
| 470 | # we have to build procs with the fully qualified names, and |
| 471 | # have the procs point to the aliases. |
| 472 | |
| 473 | if {[regexp {::} $name]} { |
| 474 | set exportCmd [list _%@namespace export [namespace tail $name]] |
| 475 | $parser eval [list _%@namespace eval $ns $exportCmd] |
| 476 | |
| 477 | # The following proc definition does not work if you |
| 478 | # want to tolerate space or something else diabolical |
| 479 | # in the procedure name, (i.e., space in $alias) |
| 480 | # The following does not work: |
| 481 | # "_%@eval {$alias} \$args" |
| 482 | # because $alias gets concat'ed to $args. |
| 483 | # The following does not work because $cmd is somehow undefined |
| 484 | # "set cmd {$alias} \; _%@eval {\$cmd} \$args" |
| 485 | # A gold star to someone that can make test |
| 486 | # autoMkindex-3.3 work properly |
| 487 | |
| 488 | set alias [namespace tail $fakeName] |
| 489 | $parser invokehidden proc $name {args} "_%@eval {$alias} \$args" |
| 490 | $parser alias $alias $fakeName |
| 491 | } else { |
| 492 | $parser alias $name $fakeName |
| 493 | } |
| 494 | return |
| 495 | } |
| 496 | |
| 497 | # auto_mkindex_parser::fullname -- |
| 498 | # Used by commands like "proc" within the auto_mkindex parser. |
| 499 | # Returns the qualified namespace name for the "name" argument. |
| 500 | # If the "name" does not start with "::", elements are added from |
| 501 | # the current namespace stack to produce a qualified name. Then, |
| 502 | # the name is examined to see whether or not it should really be |
| 503 | # qualified. If the name has more than the leading "::", it is |
| 504 | # returned as a fully qualified name. Otherwise, it is returned |
| 505 | # as a simple name. That way, the Tcl autoloader will recognize |
| 506 | # it properly. |
| 507 | # |
| 508 | # Arguments: |
| 509 | # name - Name that is being added to index. |
| 510 | |
| 511 | proc auto_mkindex_parser::fullname {name} { |
| 512 | variable contextStack |
| 513 | |
| 514 | if {![string match ::* $name]} { |
| 515 | foreach ns $contextStack { |
| 516 | set name "${ns}::$name" |
| 517 | if {[string match ::* $name]} { |
| 518 | break |
| 519 | } |
| 520 | } |
| 521 | } |
| 522 | |
| 523 | if {[string equal [namespace qualifiers $name] ""]} { |
| 524 | set name [namespace tail $name] |
| 525 | } elseif {![string match ::* $name]} { |
| 526 | set name "::$name" |
| 527 | } |
| 528 | |
| 529 | # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse |
| 530 | # that replacement. |
| 531 | regsub -all "\0" $name "\$" name |
| 532 | return $name |
| 533 | } |
| 534 | |
| 535 | # Register all of the procedures for the auto_mkindex parser that |
| 536 | # will build the "tclIndex" file. |
| 537 | |
| 538 | # AUTO MKINDEX: proc name arglist body |
| 539 | # Adds an entry to the auto index list for the given procedure name. |
| 540 | |
| 541 | auto_mkindex_parser::command proc {name args} { |
| 542 | variable index |
| 543 | variable scriptFile |
| 544 | # Do some fancy reformatting on the "source" call to handle platform |
| 545 | # differences with respect to pathnames. Use format just so that the |
| 546 | # command is a little easier to read (otherwise it'd be full of |
| 547 | # backslashed dollar signs, etc. |
| 548 | append index [list set auto_index([fullname $name])] \ |
| 549 | [format { [list source [file join $dir %s]]} \ |
| 550 | [file split $scriptFile]] "\n" |
| 551 | } |
| 552 | |
| 553 | # Conditionally add support for Tcl byte code files. There are some |
| 554 | # tricky details here. First, we need to get the tbcload library |
| 555 | # initialized in the current interpreter. We cannot load tbcload into the |
| 556 | # slave until we have done so because it needs access to the tcl_patchLevel |
| 557 | # variable. Second, because the package index file may defer loading the |
| 558 | # library until we invoke a command, we need to explicitly invoke auto_load |
| 559 | # to force it to be loaded. This should be a noop if the package has |
| 560 | # already been loaded |
| 561 | |
| 562 | auto_mkindex_parser::hook { |
| 563 | if {![catch {package require tbcload}]} { |
| 564 | if {[llength [info commands tbcload::bcproc]] == 0} { |
| 565 | auto_load tbcload::bcproc |
| 566 | } |
| 567 | load {} tbcload $auto_mkindex_parser::parser |
| 568 | |
| 569 | # AUTO MKINDEX: tbcload::bcproc name arglist body |
| 570 | # Adds an entry to the auto index list for the given pre-compiled |
| 571 | # procedure name. |
| 572 | |
| 573 | auto_mkindex_parser::commandInit tbcload::bcproc {name args} { |
| 574 | variable index |
| 575 | variable scriptFile |
| 576 | # Do some nice reformatting of the "source" call, to get around |
| 577 | # path differences on different platforms. We use the format |
| 578 | # command just so that the code is a little easier to read. |
| 579 | append index [list set auto_index([fullname $name])] \ |
| 580 | [format { [list source [file join $dir %s]]} \ |
| 581 | [file split $scriptFile]] "\n" |
| 582 | } |
| 583 | } |
| 584 | } |
| 585 | |
| 586 | # AUTO MKINDEX: namespace eval name command ?arg arg...? |
| 587 | # Adds the namespace name onto the context stack and evaluates the |
| 588 | # associated body of commands. |
| 589 | # |
| 590 | # AUTO MKINDEX: namespace import ?-force? pattern ?pattern...? |
| 591 | # Performs the "import" action in the parser interpreter. This is |
| 592 | # important for any commands contained in a namespace that affect |
| 593 | # the index. For example, a script may say "itcl::class ...", |
| 594 | # or it may import "itcl::*" and then say "class ...". This |
| 595 | # procedure does the import operation, but keeps track of imported |
| 596 | # patterns so we can remove the imports later. |
| 597 | |
| 598 | auto_mkindex_parser::command namespace {op args} { |
| 599 | switch -- $op { |
| 600 | eval { |
| 601 | variable parser |
| 602 | variable contextStack |
| 603 | |
| 604 | set name [lindex $args 0] |
| 605 | set args [lrange $args 1 end] |
| 606 | |
| 607 | set contextStack [linsert $contextStack 0 $name] |
| 608 | $parser eval [list _%@namespace eval $name] $args |
| 609 | set contextStack [lrange $contextStack 1 end] |
| 610 | } |
| 611 | import { |
| 612 | variable parser |
| 613 | variable imports |
| 614 | foreach pattern $args { |
| 615 | if {[string compare $pattern "-force"]} { |
| 616 | lappend imports $pattern |
| 617 | } |
| 618 | } |
| 619 | catch {$parser eval "_%@namespace import $args"} |
| 620 | } |
| 621 | } |
| 622 | } |
| 623 | |
| 624 | return |