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