Initial bulk commit for "Git on MSys"
[msysgit/historical-msysgit.git] / mingw / lib / tcl8.4 / auto.tcl
blob80fc2a2283c1144f9e9274093bdc37ab5111dc69
1 # auto.tcl --
3 # utility procs formerly in init.tcl dealing with auto execution
4 # of commands and can be auto loaded themselves.
6 # RCS: @(#) $Id: auto.tcl,v 1.12.2.10 2005/07/23 03:31:41 dgp Exp $
8 # Copyright (c) 1991-1993 The Regents of the University of California.
9 # Copyright (c) 1994-1998 Sun Microsystems, Inc.
11 # See the file "license.terms" for information on usage and redistribution
12 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15 # auto_reset --
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.
22 # Arguments:
23 # None.
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 {}
36 unset -nocomplain auto_execs auto_index auto_oldpath
39 # tcl_findLibrary --
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.
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)
53 proc tcl_findLibrary {basename version patch initScript enVarName varName} {
54 upvar #0 $varName the_library
55 global env errorInfo
57 set dirs {}
58 set errors {}
60 # The C application may have hardwired a path, which we honor
62 if {[info exists the_library] && $the_library ne ""} {
63 lappend dirs $the_library
64 } else {
66 # Do the canonical search
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.
72 if {[info exists env($enVarName)]} {
73 lappend dirs $env($enVarName)
76 # 2. In the package script directory registered within
77 # the configuration of the package itself.
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
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]
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]
108 # Remaining locations are out of date (when relevant, they ought
109 # to be covered by the $::auto_path seach above).
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)
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]
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.
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]
144 if {[info exists seen($norm)]} { continue }
145 set seen($norm) ""
146 lappend uniqdirs $i
148 set dirs $uniqdirs
149 foreach i $dirs {
150 set the_library $i
151 set file [file join $i $initScript]
153 # source everything when in a safe interpreter because
154 # we have a source command, but no file exists command
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"
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
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.
183 if {[interp issafe]} {
184 return ;# Stop sourcing the file here
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.
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.
199 proc auto_mkindex {dir args} {
200 global errorCode errorInfo
202 if {[interp issafe]} {
203 error "can't generate index within safe interpreter"
206 set oldDir [pwd]
207 cd $dir
208 set dir [pwd]
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
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
232 auto_mkindex_parser::cleanup
234 set fid [open "tclIndex" w]
235 puts -nonewline $fid $index
236 close $fid
237 cd $oldDir
240 # Original version of auto_mkindex that just searches the source
241 # code for "proc" at the beginning of the line.
243 proc 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
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"
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
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
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.
300 namespace 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
308 proc init {} {
309 variable parser
310 variable initCommands
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} {}
323 # We'll need access to the "namespace" command within the
324 # interp. Put it back, but move it out of the way.
326 $parser expose namespace
327 $parser invokehidden rename namespace _%@namespace
328 $parser expose eval
329 $parser invokehidden rename eval _%@eval
331 # Install all the registered psuedo-command implementations
333 foreach cmd $initCommands {
334 eval $cmd
338 proc cleanup {} {
339 variable parser
340 interp delete $parser
341 unset parser
345 # auto_mkindex_parser::mkindex --
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.
352 # Arguments:
353 # file Name of Tcl source file to be indexed.
355 proc auto_mkindex_parser::mkindex {file} {
356 variable parser
357 variable index
358 variable scriptFile
359 variable contextStack
360 variable imports
362 set scriptFile $file
364 set fid [open $file]
365 set contents [read $fid]
366 close $fid
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]
378 set index ""
379 set contextStack ""
380 set imports ""
382 $parser eval $contents
384 foreach name $imports {
385 catch {$parser eval [list _%@namespace forget $name]}
387 return $index
390 # auto_mkindex_parser::hook command
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
397 proc auto_mkindex_parser::hook {cmd} {
398 variable initCommands
400 lappend initCommands $cmd
403 # auto_mkindex_parser::slavehook command
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.
409 proc auto_mkindex_parser::slavehook {cmd} {
410 variable initCommands
412 # The $parser variable is defined to be the name of the
413 # slave interpreter when this command is used later.
415 lappend initCommands "\$parser eval [list $cmd]"
418 # auto_mkindex_parser::command --
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.
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.
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.
435 proc auto_mkindex_parser::command {name arglist body} {
436 hook [list auto_mkindex_parser::commandInit $name $arglist $body]
439 # auto_mkindex_parser::commandInit --
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.
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.
449 proc auto_mkindex_parser::commandInit {name arglist body} {
450 variable parser
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]
459 proc $fakeName $arglist $body
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.
466 if {[string match *::* $name]} {
467 set exportCmd [list _%@namespace export [namespace tail $name]]
468 $parser eval [list _%@namespace eval $ns $exportCmd]
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
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
487 return
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.
501 # Arguments:
502 # name - Name that is being added to index.
504 proc auto_mkindex_parser::fullname {name} {
505 variable contextStack
507 if {![string match ::* $name]} {
508 foreach ns $contextStack {
509 set name "${ns}::$name"
510 if {[string match ::* $name]} {
511 break
516 if {[namespace qualifiers $name] eq ""} {
517 set name [namespace tail $name]
518 } elseif {![string match ::* $name]} {
519 set name "::$name"
522 # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse
523 # that replacement.
524 return [string map "\u0000 $" $name]
527 # Register all of the procedures for the auto_mkindex parser that
528 # will build the "tclIndex" file.
530 # AUTO MKINDEX: proc name arglist body
531 # Adds an entry to the auto index list for the given procedure name.
533 auto_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"
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
554 auto_mkindex_parser::hook {
555 if {![catch {package require tbcload}]} {
556 if {[namespace which -command tbcload::bcproc] eq ""} {
557 auto_load tbcload::bcproc
559 load {} tbcload $auto_mkindex_parser::parser
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.
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"
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.
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.
590 auto_mkindex_parser::command namespace {op args} {
591 switch -- $op {
592 eval {
593 variable parser
594 variable contextStack
596 set name [lindex $args 0]
597 set args [lrange $args 1 end]
599 set contextStack [linsert $contextStack 0 $name]
600 $parser eval [list _%@namespace eval $name] $args
601 set contextStack [lrange $contextStack 1 end]
603 import {
604 variable parser
605 variable imports
606 foreach pattern $args {
607 if {$pattern ne "-force"} {
608 lappend imports $pattern
611 catch {$parser eval "_%@namespace import $args"}
616 return