3 # utility procs formerly in init.tcl dealing with auto execution
4 # of commands and can be auto loaded themselves.
6 # Copyright (c) 1991-1993 The Regents of the University of California.
7 # Copyright (c) 1994-1998 Sun Microsystems, Inc.
9 # See the file "license.terms" for information on usage and redistribution
10 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15 # Destroy all cached information for auto-loading and auto-execution,
16 # so that the information gets recomputed the next time it's needed.
17 # Also delete any commands that are listed in the auto-load index.
23 if {[array exists
::auto_index]} {
24 foreach cmdName
[array names
::auto_index] {
25 set fqcn
[namespace which
$cmdName]
26 if {$fqcn eq
""} {continue}
30 unset -nocomplain ::auto_execs ::auto_index ::tcl::auto_oldpath
31 if {[catch {llength $::auto_path}]} {
32 set ::auto_path [list [info library
]]
34 if {[info library
] ni
$::auto_path} {
35 lappend ::auto_path [info library
]
42 # This is a utility for extensions that searches for a library directory
43 # using a canonical searching algorithm. A side effect is to source
44 # the initialization script and set a global library variable.
47 # basename Prefix of the directory name, (e.g., "tk")
48 # version Version number of the package, (e.g., "8.0")
49 # patch Patchlevel of the package, (e.g., "8.0.3")
50 # initScript Initialization script to source (e.g., tk.tcl)
51 # enVarName environment variable to honor (e.g., TK_LIBRARY)
52 # varName Global variable to set when done (e.g., tk_library)
54 proc tcl_findLibrary {basename version patch initScript enVarName varName
} {
55 upvar #0 $varName the_library
61 # The C application may have hardwired a path, which we honor
63 if {[info exists the_library
] && $the_library ne
""} {
64 lappend dirs
$the_library
67 # Do the canonical search
69 # 1. From an environment variable, if it exists.
70 # Placing this first gives the end-user ultimate control
71 # to work-around any bugs, or to customize.
73 if {[info exists env
($enVarName)]} {
74 lappend dirs
$env($enVarName)
77 # 2. In the package script directory registered within
78 # the configuration of the package itself.
81 ::${basename
}::pkgconfig get scriptdir
,runtime
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)
103 # Remaining locations are out of date (when relevant, they ought
104 # to be covered by the $::auto_path seach above) and disabled.
106 # ../../library (From unix/arch directory in build hierarchy)
107 # ../../foo1.0.1/library
108 # (From unix directory in parallel build hierarchy)
109 # ../../../foo1.0.1/library
110 # (From unix/arch directory in parallel build hierarchy)
112 set parentDir
[file dirname
[file dirname
[info nameofexecutable
]]]
113 set grandParentDir
[file dirname
$parentDir]
114 lappend dirs
[file join $parentDir lib
$basename$version]
115 lappend dirs
[file join $grandParentDir lib
$basename$version]
116 lappend dirs
[file join $parentDir library
]
118 lappend dirs
[file join $grandParentDir library
]
119 lappend dirs
[file join $grandParentDir $basename$patch library
]
120 lappend dirs
[file join [file dirname
$grandParentDir] \
121 $basename$patch library
]
124 # uniquify $dirs in order
127 # Take note that the [file normalize] below has been noted to
128 # cause difficulties for the freewrap utility. See Bug 1072136.
129 # Until freewrap resolves the matter, one might work around the
130 # problem by disabling that branch.
131 if {[interp issafe
]} {
134 set norm
[file normalize
$i]
136 if {[info exists seen
($norm)]} { continue }
143 set file [file join $i $initScript]
145 # source everything when in a safe interpreter because
146 # we have a source command, but no file exists command
148 if {[interp issafe
] ||
[file exists
$file]} {
149 if {![catch {uplevel #0 [list source $file]} msg opts]} {
152 append errors
"$file: $msg\n"
153 append errors
[dict get
$opts -errorinfo]\n
157 unset -nocomplain the_library
158 set msg
"Can't find a usable $initScript in the following directories: \n"
159 append msg
" $dirs\n\n"
160 append msg
"$errors\n\n"
161 append msg
"This probably means that $basename wasn't installed properly.\n"
166 # ----------------------------------------------------------------------
168 # ----------------------------------------------------------------------
169 # The following procedures are used to generate the tclIndex file
170 # from Tcl source files. They use a special safe interpreter to
171 # parse Tcl source files, writing out index entries as "proc"
172 # commands are encountered. This implementation won't work in a
173 # safe interpreter, since a safe interpreter can't create the
174 # special parser and mess with its commands.
176 if {[interp issafe
]} {
177 return ;# Stop sourcing the file here
181 # Regenerate a tclIndex file from Tcl source files. Takes as argument
182 # the name of the directory in which the tclIndex file is to be placed,
183 # followed by any number of glob patterns to use in that directory to
184 # locate all of the relevant files.
187 # dir - Name of the directory in which to create an index.
188 # args - Any number of additional arguments giving the
189 # names of files within dir. If no additional
190 # are given auto_mkindex will look for *.tcl.
192 proc auto_mkindex {dir args
} {
193 if {[interp issafe
]} {
194 error "can't generate index within safe interpreter"
201 append index
"# Tcl autoload index file, version 2.0\n"
202 append index
"# This file is generated by the \"auto_mkindex\" command\n"
203 append index
"# and sourced to set up indexing information for one or\n"
204 append index
"# more commands. Typically each line is a command that\n"
205 append index
"# sets an element in the auto_index array, where the\n"
206 append index
"# element name is the name of a command and the value is\n"
207 append index
"# a script that loads the command.\n\n"
208 if {[llength $args] == 0} {
212 auto_mkindex_parser
::init
213 foreach file [glob -- {*}$args] {
214 if {[catch {auto_mkindex_parser
::mkindex $file} msg opts
] == 0} {
218 return -options $opts $msg
221 auto_mkindex_parser
::cleanup
223 set fid
[open "tclIndex" w
]
224 puts -nonewline $fid $index
229 # Original version of auto_mkindex that just searches the source
230 # code for "proc" at the beginning of the line.
232 proc auto_mkindex_old {dir args
} {
236 append index
"# Tcl autoload index file, version 2.0\n"
237 append index
"# This file is generated by the \"auto_mkindex\" command\n"
238 append index
"# and sourced to set up indexing information for one or\n"
239 append index
"# more commands. Typically each line is a command that\n"
240 append index
"# sets an element in the auto_index array, where the\n"
241 append index
"# element name is the name of a command and the value is\n"
242 append index
"# a script that loads the command.\n\n"
243 if {[llength $args] == 0} {
246 foreach file [glob -- {*}$args] {
250 while {[gets $f line
] >= 0} {
251 if {[regexp {^
proc[ ]+([^
]*)} $line match procName
]} {
252 set procName
[lindex [auto_qualify $procName "::"] 0]
253 append index
"set [list auto_index($procName)]"
254 append index
" \[list source \[file join \$dir [list $file]\]\]\n"
262 return -options $opts $msg
267 set f
[open tclIndex w
]
268 puts -nonewline $f $index
275 error $msg $info $code
276 return -options $opts $msg
280 # Create a safe interpreter that can be used to parse Tcl source files
281 # generate a tclIndex file for autoloading. This interp contains
282 # commands for things that need index entries. Each time a command
283 # is executed, it writes an entry out to the index file.
285 namespace eval auto_mkindex_parser
{
286 variable parser
"" ;# parser used to build index
287 variable index
"" ;# maintains index as it is built
288 variable scriptFile
"" ;# name of file being processed
289 variable contextStack
"" ;# stack of namespace scopes
290 variable imports
"" ;# keeps track of all imported cmds
291 variable initCommands
;# list of commands that create aliases
292 if {![info exists initCommands
]} {
293 set initCommands
[list]
298 variable initCommands
300 if {![interp issafe
]} {
301 set parser
[interp create
-safe]
305 $parser hide
namespace
308 $parser invokehidden
namespace delete
::
309 $parser invokehidden
proc unknown {args
} {}
311 # We'll need access to the "namespace" command within the
312 # interp. Put it back, but move it out of the way.
314 $parser expose
namespace
315 $parser invokehidden
rename namespace _
%@namespace
317 $parser invokehidden
rename eval _
%@eval
319 # Install all the registered psuedo-command implementations
321 foreach cmd
$initCommands {
328 interp delete
$parser
333 # auto_mkindex_parser::mkindex --
335 # Used by the "auto_mkindex" command to create a "tclIndex" file for
336 # the given Tcl source file. Executes the commands in the file, and
337 # handles things like the "proc" command by adding an entry for the
338 # index file. Returns a string that represents the index file.
341 # file Name of Tcl source file to be indexed.
343 proc auto_mkindex_parser
::mkindex {file} {
347 variable contextStack
353 set contents
[read $fid]
356 # There is one problem with sourcing files into the safe
357 # interpreter: references like "$x" will fail since code is not
358 # really being executed and variables do not really exist.
359 # To avoid this, we replace all $ with \0 (literally, the null char)
360 # later, when getting proc names we will have to reverse this replacement,
361 # in case there were any $ in the proc name. This will cause a problem
362 # if somebody actually tries to have a \0 in their proc name. Too bad
364 set contents
[string map
[list \$ \0] $contents]
370 $parser eval $contents
372 foreach name
$imports {
373 catch {$parser eval [list _
%@namespace forget
$name]}
378 # auto_mkindex_parser::hook command
380 # Registers a Tcl command to evaluate when initializing the
381 # slave interpreter used by the mkindex parser.
382 # The command is evaluated in the master interpreter, and can
383 # use the variable auto_mkindex_parser::parser to get to the slave
385 proc auto_mkindex_parser
::hook {cmd
} {
386 variable initCommands
388 lappend initCommands
$cmd
391 # auto_mkindex_parser::slavehook command
393 # Registers a Tcl command to evaluate when initializing the
394 # slave interpreter used by the mkindex parser.
395 # The command is evaluated in the slave interpreter.
397 proc auto_mkindex_parser
::slavehook {cmd
} {
398 variable initCommands
400 # The $parser variable is defined to be the name of the
401 # slave interpreter when this command is used later.
403 lappend initCommands
"\$parser eval [list $cmd]"
406 # auto_mkindex_parser::command --
408 # Registers a new command with the "auto_mkindex_parser" interpreter
409 # that parses Tcl files. These commands are fake versions of things
410 # like the "proc" command. When you execute them, they simply write
411 # out an entry to a "tclIndex" file for auto-loading.
413 # This procedure allows extensions to register their own commands
414 # with the auto_mkindex facility. For example, a package like
415 # [incr Tcl] might register a "class" command so that class definitions
416 # could be added to a "tclIndex" file for auto-loading.
419 # name Name of command recognized in Tcl files.
420 # arglist Argument list for command.
421 # body Implementation of command to handle indexing.
423 proc auto_mkindex_parser
::command {name arglist body
} {
424 hook
[list auto_mkindex_parser
::commandInit $name $arglist $body]
427 # auto_mkindex_parser::commandInit --
429 # This does the actual work set up by auto_mkindex_parser::command
430 # This is called when the interpreter used by the parser is created.
433 # name Name of command recognized in Tcl files.
434 # arglist Argument list for command.
435 # body Implementation of command to handle indexing.
437 proc auto_mkindex_parser
::commandInit {name arglist body
} {
440 set ns
[namespace qualifiers
$name]
441 set tail
[namespace tail
$name]
443 set fakeName
[namespace current
]::_%@fake_
$tail
445 set fakeName
[namespace current
]::[string map
{:: _
} _
%@fake_
$name]
447 proc $fakeName $arglist $body
449 # YUK! Tcl won't let us alias fully qualified command names,
450 # so we can't handle names like "::itcl::class". Instead,
451 # we have to build procs with the fully qualified names, and
452 # have the procs point to the aliases.
454 if {[string match
*::* $name]} {
455 set exportCmd
[list _
%@namespace export
[namespace tail
$name]]
456 $parser eval [list _
%@namespace eval $ns $exportCmd]
458 # The following proc definition does not work if you
459 # want to tolerate space or something else diabolical
460 # in the procedure name, (i.e., space in $alias)
461 # The following does not work:
462 # "_%@eval {$alias} \$args"
463 # because $alias gets concat'ed to $args.
464 # The following does not work because $cmd is somehow undefined
465 # "set cmd {$alias} \; _%@eval {\$cmd} \$args"
466 # A gold star to someone that can make test
467 # autoMkindex-3.3 work properly
469 set alias
[namespace tail
$fakeName]
470 $parser invokehidden
proc $name {args
} "_%@eval {$alias} \$args"
471 $parser alias
$alias $fakeName
473 $parser alias
$name $fakeName
478 # auto_mkindex_parser::fullname --
479 # Used by commands like "proc" within the auto_mkindex parser.
480 # Returns the qualified namespace name for the "name" argument.
481 # If the "name" does not start with "::", elements are added from
482 # the current namespace stack to produce a qualified name. Then,
483 # the name is examined to see whether or not it should really be
484 # qualified. If the name has more than the leading "::", it is
485 # returned as a fully qualified name. Otherwise, it is returned
486 # as a simple name. That way, the Tcl autoloader will recognize
490 # name - Name that is being added to index.
492 proc auto_mkindex_parser
::fullname {name
} {
493 variable contextStack
495 if {![string match
::* $name]} {
496 foreach ns
$contextStack {
497 set name
"${ns}::$name"
498 if {[string match
::* $name]} {
504 if {[namespace qualifiers
$name] eq
""} {
505 set name
[namespace tail
$name]
506 } elseif
{![string match
::* $name]} {
510 # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse
512 return [string map
[list \0 \$] $name]
515 if {[llength $::auto_mkindex_parser::initCommands]} {
519 # Register all of the procedures for the auto_mkindex parser that
520 # will build the "tclIndex" file.
522 # AUTO MKINDEX: proc name arglist body
523 # Adds an entry to the auto index list for the given procedure name.
525 auto_mkindex_parser
::command proc {name args
} {
528 # Do some fancy reformatting on the "source" call to handle platform
529 # differences with respect to pathnames. Use format just so that the
530 # command is a little easier to read (otherwise it'd be full of
531 # backslashed dollar signs, etc.
532 append index
[list set auto_index
([fullname
$name])] \
533 [format { [list source [file join $dir %s
]]} \
534 [file split $scriptFile]] "\n"
537 # Conditionally add support for Tcl byte code files. There are some
538 # tricky details here. First, we need to get the tbcload library
539 # initialized in the current interpreter. We cannot load tbcload into the
540 # slave until we have done so because it needs access to the tcl_patchLevel
541 # variable. Second, because the package index file may defer loading the
542 # library until we invoke a command, we need to explicitly invoke auto_load
543 # to force it to be loaded. This should be a noop if the package has
544 # already been loaded
546 auto_mkindex_parser
::hook {
547 if {![catch {package require tbcload
}]} {
548 if {[namespace which
-command tbcload
::bcproc] eq
""} {
549 auto_load tbcload
::bcproc
551 load {} tbcload
$auto_mkindex_parser::parser
553 # AUTO MKINDEX: tbcload::bcproc name arglist body
554 # Adds an entry to the auto index list for the given pre-compiled
557 auto_mkindex_parser
::commandInit tbcload
::bcproc {name args
} {
560 # Do some nice reformatting of the "source" call, to get around
561 # path differences on different platforms. We use the format
562 # command just so that the code is a little easier to read.
563 append index
[list set auto_index
([fullname
$name])] \
564 [format { [list source [file join $dir %s
]]} \
565 [file split $scriptFile]] "\n"
570 # AUTO MKINDEX: namespace eval name command ?arg arg...?
571 # Adds the namespace name onto the context stack and evaluates the
572 # associated body of commands.
574 # AUTO MKINDEX: namespace import ?-force? pattern ?pattern...?
575 # Performs the "import" action in the parser interpreter. This is
576 # important for any commands contained in a namespace that affect
577 # the index. For example, a script may say "itcl::class ...",
578 # or it may import "itcl::*" and then say "class ...". This
579 # procedure does the import operation, but keeps track of imported
580 # patterns so we can remove the imports later.
582 auto_mkindex_parser
::command namespace {op args
} {
586 variable contextStack
588 set name
[lindex $args 0]
589 set args
[lrange $args 1 end
]
591 set contextStack
[linsert $contextStack 0 $name]
592 $parser eval [list _
%@namespace eval $name] $args
593 set contextStack
[lrange $contextStack 1 end
]
598 foreach pattern
$args {
599 if {$pattern ne
"-force"} {
600 lappend imports
$pattern
603 catch {$parser eval "_%@namespace import $args"}