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.28 2006/11/03 00:34:52 hobbs 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.
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 commands that are listed in the auto-load index.
25 if {[array exists
::auto_index]} {
26 foreach cmdName
[array names
::auto_index] {
27 set fqcn
[namespace which
$cmdName]
28 if {$fqcn eq
""} {continue}
32 unset -nocomplain ::auto_execs ::auto_index ::tcl::auto_oldpath
33 if {[catch {llength $::auto_path}]} {
34 set ::auto_path [list [info library
]]
36 if {[info library
] ni
$::auto_path} {
37 lappend ::auto_path [info library
]
44 # This is a utility for extensions that searches for a library directory
45 # using a canonical searching algorithm. A side effect is to source
46 # the initialization script and set a global library variable.
49 # basename Prefix of the directory name, (e.g., "tk")
50 # version Version number of the package, (e.g., "8.0")
51 # patch Patchlevel of the package, (e.g., "8.0.3")
52 # initScript Initialization script to source (e.g., tk.tcl)
53 # enVarName environment variable to honor (e.g., TK_LIBRARY)
54 # varName Global variable to set when done (e.g., tk_library)
56 proc tcl_findLibrary {basename version patch initScript enVarName varName
} {
57 upvar #0 $varName the_library
63 # The C application may have hardwired a path, which we honor
65 if {[info exists the_library
] && $the_library ne
""} {
66 lappend dirs
$the_library
69 # Do the canonical search
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.
75 if {[info exists env
($enVarName)]} {
76 lappend dirs
$env($enVarName)
79 # 2. In the package script directory registered within
80 # the configuration of the package itself.
83 ::${basename
}::pkgconfig get scriptdir
,runtime
88 # 3. Relative to auto_path directories. This checks relative to the
89 # Tcl library as well as allowing loading of libraries added to the
90 # auto_path that is not relative to the core library or binary paths.
91 foreach d
$::auto_path {
92 lappend dirs
[file join $d $basename$version]
93 if {$::tcl_platform(platform
) eq
"unix"
94 && $::tcl_platform(os
) eq
"Darwin"} {
95 # 4. On MacOSX, check the Resources/Scripts subdir too
96 lappend dirs
[file join $d $basename$version Resources Scripts
]
100 # 3. Various locations relative to the executable
101 # ../lib/foo1.0 (From bin directory in install hierarchy)
102 # ../../lib/foo1.0 (From bin/arch directory in install hierarchy)
103 # ../library (From unix directory in build hierarchy)
105 # Remaining locations are out of date (when relevant, they ought
106 # to be covered by the $::auto_path seach above) and disabled.
108 # ../../library (From unix/arch directory in build hierarchy)
109 # ../../foo1.0.1/library
110 # (From unix directory in parallel build hierarchy)
111 # ../../../foo1.0.1/library
112 # (From unix/arch directory in parallel build hierarchy)
114 set parentDir
[file dirname
[file dirname
[info nameofexecutable
]]]
115 set grandParentDir
[file dirname
$parentDir]
116 lappend dirs
[file join $parentDir lib
$basename$version]
117 lappend dirs
[file join $grandParentDir lib
$basename$version]
118 lappend dirs
[file join $parentDir library
]
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
129 # Take note that the [file normalize] below has been noted to
130 # cause difficulties for the freewrap utility. See Bug 1072136.
131 # Until freewrap resolves the matter, one might work around the
132 # problem by disabling that branch.
133 if {[interp issafe
]} {
136 set norm
[file normalize
$i]
138 if {[info exists seen
($norm)]} { continue }
145 set file [file join $i $initScript]
147 # source everything when in a safe interpreter because
148 # we have a source command, but no file exists command
150 if {[interp issafe
] ||
[file exists
$file]} {
151 if {![catch {uplevel #0 [list source $file]} msg opts]} {
154 append errors
"$file: $msg\n"
155 append errors
[dict get
$opts -errorinfo]\n
159 unset -nocomplain the_library
160 set msg
"Can't find a usable $initScript in the following directories: \n"
161 append msg
" $dirs\n\n"
162 append msg
"$errors\n\n"
163 append msg
"This probably means that $basename wasn't installed properly.\n"
168 # ----------------------------------------------------------------------
170 # ----------------------------------------------------------------------
171 # The following procedures are used to generate the tclIndex file
172 # from Tcl source files. They use a special safe interpreter to
173 # parse Tcl source files, writing out index entries as "proc"
174 # commands are encountered. This implementation won't work in a
175 # safe interpreter, since a safe interpreter can't create the
176 # special parser and mess with its commands.
178 if {[interp issafe
]} {
179 return ;# Stop sourcing the file here
183 # Regenerate a tclIndex file from Tcl source files. Takes as argument
184 # the name of the directory in which the tclIndex file is to be placed,
185 # followed by any number of glob patterns to use in that directory to
186 # locate all of the relevant files.
189 # dir - Name of the directory in which to create an index.
190 # args - Any number of additional arguments giving the
191 # names of files within dir. If no additional
192 # are given auto_mkindex will look for *.tcl.
194 proc auto_mkindex {dir args
} {
195 if {[interp issafe
]} {
196 error "can't generate index within safe interpreter"
203 append index
"# Tcl autoload index file, version 2.0\n"
204 append index
"# This file is generated by the \"auto_mkindex\" command\n"
205 append index
"# and sourced to set up indexing information for one or\n"
206 append index
"# more commands. Typically each line is a command that\n"
207 append index
"# sets an element in the auto_index array, where the\n"
208 append index
"# element name is the name of a command and the value is\n"
209 append index
"# a script that loads the command.\n\n"
210 if {[llength $args] == 0} {
214 auto_mkindex_parser
::init
215 foreach file [glob -- {*}$args] {
216 if {[catch {auto_mkindex_parser
::mkindex $file} msg opts
] == 0} {
220 return -options $opts $msg
223 auto_mkindex_parser
::cleanup
225 set fid
[open "tclIndex" w
]
226 puts -nonewline $fid $index
231 # Original version of auto_mkindex that just searches the source
232 # code for "proc" at the beginning of the line.
234 proc auto_mkindex_old {dir args
} {
238 append index
"# Tcl autoload index file, version 2.0\n"
239 append index
"# This file is generated by the \"auto_mkindex\" command\n"
240 append index
"# and sourced to set up indexing information for one or\n"
241 append index
"# more commands. Typically each line is a command that\n"
242 append index
"# sets an element in the auto_index array, where the\n"
243 append index
"# element name is the name of a command and the value is\n"
244 append index
"# a script that loads the command.\n\n"
245 if {[llength $args] == 0} {
248 foreach file [glob -- {*}$args] {
252 while {[gets $f line
] >= 0} {
253 if {[regexp {^
proc[ ]+([^
]*)} $line match procName
]} {
254 set procName
[lindex [auto_qualify $procName "::"] 0]
255 append index
"set [list auto_index($procName)]"
256 append index
" \[list source \[file join \$dir [list $file]\]\]\n"
264 return -options $opts $msg
269 set f
[open tclIndex w
]
270 puts -nonewline $f $index
277 error $msg $info $code
278 return -options $opts $msg
282 # Create a safe interpreter that can be used to parse Tcl source files
283 # generate a tclIndex file for autoloading. This interp contains
284 # commands for things that need index entries. Each time a command
285 # is executed, it writes an entry out to the index file.
287 namespace eval auto_mkindex_parser
{
288 variable parser
"" ;# parser used to build index
289 variable index
"" ;# maintains index as it is built
290 variable scriptFile
"" ;# name of file being processed
291 variable contextStack
"" ;# stack of namespace scopes
292 variable imports
"" ;# keeps track of all imported cmds
293 variable initCommands
;# list of commands that create aliases
294 if {![info exists initCommands
]} {
295 set initCommands
[list]
300 variable initCommands
302 if {![interp issafe
]} {
303 set parser
[interp create
-safe]
307 $parser hide
namespace
310 $parser invokehidden
namespace delete
::
311 $parser invokehidden
proc unknown {args
} {}
313 # We'll need access to the "namespace" command within the
314 # interp. Put it back, but move it out of the way.
316 $parser expose
namespace
317 $parser invokehidden
rename namespace _
%@namespace
319 $parser invokehidden
rename eval _
%@eval
321 # Install all the registered psuedo-command implementations
323 foreach cmd
$initCommands {
330 interp delete
$parser
335 # auto_mkindex_parser::mkindex --
337 # Used by the "auto_mkindex" command to create a "tclIndex" file for
338 # the given Tcl source file. Executes the commands in the file, and
339 # handles things like the "proc" command by adding an entry for the
340 # index file. Returns a string that represents the index file.
343 # file Name of Tcl source file to be indexed.
345 proc auto_mkindex_parser
::mkindex {file} {
349 variable contextStack
355 set contents
[read $fid]
358 # There is one problem with sourcing files into the safe
359 # interpreter: references like "$x" will fail since code is not
360 # really being executed and variables do not really exist.
361 # To avoid this, we replace all $ with \0 (literally, the null char)
362 # later, when getting proc names we will have to reverse this replacement,
363 # in case there were any $ in the proc name. This will cause a problem
364 # if somebody actually tries to have a \0 in their proc name. Too bad
366 set contents
[string map
[list \$ \0] $contents]
372 $parser eval $contents
374 foreach name
$imports {
375 catch {$parser eval [list _
%@namespace forget
$name]}
380 # auto_mkindex_parser::hook command
382 # Registers a Tcl command to evaluate when initializing the
383 # slave interpreter used by the mkindex parser.
384 # The command is evaluated in the master interpreter, and can
385 # use the variable auto_mkindex_parser::parser to get to the slave
387 proc auto_mkindex_parser
::hook {cmd
} {
388 variable initCommands
390 lappend initCommands
$cmd
393 # auto_mkindex_parser::slavehook command
395 # Registers a Tcl command to evaluate when initializing the
396 # slave interpreter used by the mkindex parser.
397 # The command is evaluated in the slave interpreter.
399 proc auto_mkindex_parser
::slavehook {cmd
} {
400 variable initCommands
402 # The $parser variable is defined to be the name of the
403 # slave interpreter when this command is used later.
405 lappend initCommands
"\$parser eval [list $cmd]"
408 # auto_mkindex_parser::command --
410 # Registers a new command with the "auto_mkindex_parser" interpreter
411 # that parses Tcl files. These commands are fake versions of things
412 # like the "proc" command. When you execute them, they simply write
413 # out an entry to a "tclIndex" file for auto-loading.
415 # This procedure allows extensions to register their own commands
416 # with the auto_mkindex facility. For example, a package like
417 # [incr Tcl] might register a "class" command so that class definitions
418 # could be added to a "tclIndex" file for auto-loading.
421 # name Name of command recognized in Tcl files.
422 # arglist Argument list for command.
423 # body Implementation of command to handle indexing.
425 proc auto_mkindex_parser
::command {name arglist body
} {
426 hook
[list auto_mkindex_parser
::commandInit $name $arglist $body]
429 # auto_mkindex_parser::commandInit --
431 # This does the actual work set up by auto_mkindex_parser::command
432 # This is called when the interpreter used by the parser is created.
435 # name Name of command recognized in Tcl files.
436 # arglist Argument list for command.
437 # body Implementation of command to handle indexing.
439 proc auto_mkindex_parser
::commandInit {name arglist body
} {
442 set ns
[namespace qualifiers
$name]
443 set tail
[namespace tail
$name]
445 set fakeName
[namespace current
]::_%@fake_
$tail
447 set fakeName
[namespace current
]::[string map
{:: _
} _
%@fake_
$name]
449 proc $fakeName $arglist $body
451 # YUK! Tcl won't let us alias fully qualified command names,
452 # so we can't handle names like "::itcl::class". Instead,
453 # we have to build procs with the fully qualified names, and
454 # have the procs point to the aliases.
456 if {[string match
*::* $name]} {
457 set exportCmd
[list _
%@namespace export
[namespace tail
$name]]
458 $parser eval [list _
%@namespace eval $ns $exportCmd]
460 # The following proc definition does not work if you
461 # want to tolerate space or something else diabolical
462 # in the procedure name, (i.e., space in $alias)
463 # The following does not work:
464 # "_%@eval {$alias} \$args"
465 # because $alias gets concat'ed to $args.
466 # The following does not work because $cmd is somehow undefined
467 # "set cmd {$alias} \; _%@eval {\$cmd} \$args"
468 # A gold star to someone that can make test
469 # autoMkindex-3.3 work properly
471 set alias
[namespace tail
$fakeName]
472 $parser invokehidden
proc $name {args
} "_%@eval {$alias} \$args"
473 $parser alias
$alias $fakeName
475 $parser alias
$name $fakeName
480 # auto_mkindex_parser::fullname --
481 # Used by commands like "proc" within the auto_mkindex parser.
482 # Returns the qualified namespace name for the "name" argument.
483 # If the "name" does not start with "::", elements are added from
484 # the current namespace stack to produce a qualified name. Then,
485 # the name is examined to see whether or not it should really be
486 # qualified. If the name has more than the leading "::", it is
487 # returned as a fully qualified name. Otherwise, it is returned
488 # as a simple name. That way, the Tcl autoloader will recognize
492 # name - Name that is being added to index.
494 proc auto_mkindex_parser
::fullname {name
} {
495 variable contextStack
497 if {![string match
::* $name]} {
498 foreach ns
$contextStack {
499 set name
"${ns}::$name"
500 if {[string match
::* $name]} {
506 if {[namespace qualifiers
$name] eq
""} {
507 set name
[namespace tail
$name]
508 } elseif
{![string match
::* $name]} {
512 # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse
514 return [string map
[list \0 \$] $name]
517 if {[llength $::auto_mkindex_parser::initCommands]} {
521 # Register all of the procedures for the auto_mkindex parser that
522 # will build the "tclIndex" file.
524 # AUTO MKINDEX: proc name arglist body
525 # Adds an entry to the auto index list for the given procedure name.
527 auto_mkindex_parser
::command proc {name args
} {
530 # Do some fancy reformatting on the "source" call to handle platform
531 # differences with respect to pathnames. Use format just so that the
532 # command is a little easier to read (otherwise it'd be full of
533 # backslashed dollar signs, etc.
534 append index
[list set auto_index
([fullname
$name])] \
535 [format { [list source [file join $dir %s
]]} \
536 [file split $scriptFile]] "\n"
539 # Conditionally add support for Tcl byte code files. There are some
540 # tricky details here. First, we need to get the tbcload library
541 # initialized in the current interpreter. We cannot load tbcload into the
542 # slave until we have done so because it needs access to the tcl_patchLevel
543 # variable. Second, because the package index file may defer loading the
544 # library until we invoke a command, we need to explicitly invoke auto_load
545 # to force it to be loaded. This should be a noop if the package has
546 # already been loaded
548 auto_mkindex_parser
::hook {
549 if {![catch {package require tbcload
}]} {
550 if {[namespace which
-command tbcload
::bcproc] eq
""} {
551 auto_load tbcload
::bcproc
553 load {} tbcload
$auto_mkindex_parser::parser
555 # AUTO MKINDEX: tbcload::bcproc name arglist body
556 # Adds an entry to the auto index list for the given pre-compiled
559 auto_mkindex_parser
::commandInit tbcload
::bcproc {name args
} {
562 # Do some nice reformatting of the "source" call, to get around
563 # path differences on different platforms. We use the format
564 # command just so that the code is a little easier to read.
565 append index
[list set auto_index
([fullname
$name])] \
566 [format { [list source [file join $dir %s
]]} \
567 [file split $scriptFile]] "\n"
572 # AUTO MKINDEX: namespace eval name command ?arg arg...?
573 # Adds the namespace name onto the context stack and evaluates the
574 # associated body of commands.
576 # AUTO MKINDEX: namespace import ?-force? pattern ?pattern...?
577 # Performs the "import" action in the parser interpreter. This is
578 # important for any commands contained in a namespace that affect
579 # the index. For example, a script may say "itcl::class ...",
580 # or it may import "itcl::*" and then say "class ...". This
581 # procedure does the import operation, but keeps track of imported
582 # patterns so we can remove the imports later.
584 auto_mkindex_parser
::command namespace {op args
} {
588 variable contextStack
590 set name
[lindex $args 0]
591 set args
[lrange $args 1 end
]
593 set contextStack
[linsert $contextStack 0 $name]
594 $parser eval [list _
%@namespace eval $name] $args
595 set contextStack
[lrange $contextStack 1 end
]
600 foreach pattern
$args {
601 if {$pattern ne
"-force"} {
602 lappend imports
$pattern
605 catch {$parser eval "_%@namespace import $args"}