root/tcl-8.0/tags/nte_1_7_0/library/init.tcl @ 1115

Revision 1115, 43.6 KB (checked in by anonymous, 15 years ago)

This commit was manufactured by cvs2svn to create tag 'nte_1_7_0'.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
Line 
1# init.tcl --
2#
3# Default system startup file for Tcl-based applications.  Defines
4# "unknown" procedure and auto-load facilities.
5#
6# SCCS: @(#) init.tcl 1.8 98/07/20 16:24:45
7#
8# Copyright (c) 1991-1993 The Regents of the University of California.
9# Copyright (c) 1994-1996 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
15if {[info commands package] == ""} {
16    error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
17}
18package require -exact Tcl 8.0
19
20# Compute the auto path to use in this interpreter.
21# (auto_path could be already set, in safe interps for instance)
22
23if {![info exists auto_path]} {
24    if {[catch {set auto_path $env(TCLLIBPATH)}]} {
25        set auto_path ""
26    }
27}
28# Don't set up the auto_path, since we want to disable auto-loading (csp)
29#if {[lsearch -exact $auto_path [info library]] < 0} {
30#    lappend auto_path [info library]
31#}
32#catch {
33#    foreach __dir $tcl_pkgPath {
34#       if {[lsearch -exact $auto_path $__dir] < 0} {
35#           lappend auto_path $__dir
36#       }
37#    }
38#    unset __dir
39#}
40
41# Windows specific initialization to handle case isses with envars
42
43if {(![interp issafe]) && ($tcl_platform(platform) == "windows")} {
44    namespace eval tcl {
45        proc envTraceProc {lo n1 n2 op} {
46            set x $::env($n2)
47            set ::env($lo) $x
48            set ::env([string toupper $lo]) $x
49        }
50    }
51    foreach p [array names env] {
52        set u [string toupper $p]
53        if {$u != $p} {
54            switch -- $u {
55                COMSPEC -
56                PATH {
57                    if {![info exists env($u)]} {
58                        set env($u) $env($p)
59                    }
60                    trace variable env($p) w [list tcl::envTraceProc $p]
61                    trace variable env($u) w [list tcl::envTraceProc $p]
62                }
63            }
64        }
65    }
66    if {[info exists p]} {
67        unset p
68    }
69    if {[info exists u]} {
70        unset u
71    }
72    if {![info exists env(COMSPEC)]} {
73        if {$tcl_platform(os) == {Windows NT}} {
74            set env(COMSPEC) cmd.exe
75        } else {
76            set env(COMSPEC) command.com
77        }
78    }
79}
80
81# Setup the unknown package handler
82
83package unknown tclPkgUnknown
84
85# Conditionalize for presence of exec.
86
87if {[info commands exec] == ""} {
88
89    # Some machines, such as the Macintosh, do not have exec. Also, on all
90    # platforms, safe interpreters do not have exec.
91
92    set auto_noexec 1
93}
94set errorCode ""
95set errorInfo ""
96
97# Define a log command (which can be overwitten to log errors
98# differently, specially when stderr is not available)
99
100if {[info commands tclLog] == ""} {
101    proc tclLog {string} {
102        catch {puts stderr $string}
103    }
104}
105
106# unknown --
107# This procedure is called when a Tcl command is invoked that doesn't
108# exist in the interpreter.  It takes the following steps to make the
109# command available:
110#
111#       1. See if the command has the form "namespace inscope ns cmd" and
112#          if so, concatenate its arguments onto the end and evaluate it.
113#
114# Arguments:
115# args -        A list whose elements are the words of the original
116#               command, including the command name.
117
118proc unknown args {
119    global auto_noexec auto_noload env unknown_pending tcl_interactive
120    global errorCode errorInfo
121
122    # If the command word has the form "namespace inscope ns cmd"
123    # then concatenate its arguments onto the end and evaluate it.
124
125    set cmd [lindex $args 0]
126    if {[regexp "^namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
127        set arglist [lrange $args 1 end]
128        set ret [catch {uplevel $cmd $arglist} result]
129        if {$ret == 0} {
130            return $result
131        } else {
132            return -code $ret -errorcode $errorCode $result
133        }
134    }
135
136    return -code error "invalid command name \"$name\""
137}
138
139# auto_load --
140# Checks a collection of library directories to see if a procedure
141# is defined in one of them.  If so, it sources the appropriate
142# library file to create the procedure.  Returns 1 if it successfully
143# loaded the procedure, 0 otherwise.
144#
145# Arguments:
146# cmd -                 Name of the command to find and load.
147# namespace (optional)  The namespace where the command is being used - must be
148#                       a canonical namespace as returned [namespace current]
149#                       for instance. If not given, namespace current is used.
150
151proc auto_load {cmd {namespace {}}} {
152    # Don't do auto-loading in this version... (csp)
153    return 0
154}
155
156# auto_load_index --
157# Loads the contents of tclIndex files on the auto_path directory
158# list.  This is usually invoked within auto_load to load the index
159# of available commands.  Returns 1 if the index is loaded, and 0 if
160# the index is already loaded and up to date.
161#
162# Arguments:
163# None.
164
165proc auto_load_index {} {
166    global auto_index auto_oldpath auto_path errorInfo errorCode
167
168    if {[info exists auto_oldpath]} {
169        if {$auto_oldpath == $auto_path} {
170            return 0
171        }
172    }
173    set auto_oldpath $auto_path
174
175    # Check if we are a safe interpreter. In that case, we support only
176    # newer format tclIndex files.
177
178    set issafe [interp issafe]
179    for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
180        set dir [lindex $auto_path $i]
181        set f ""
182        if {$issafe} {
183            catch {source [file join $dir tclIndex]}
184        } elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
185            continue
186        } else {
187            set error [catch {
188                set id [gets $f]
189                if {$id == "# Tcl autoload index file, version 2.0"} {
190                    eval [read $f]
191                } elseif {$id == \
192                    "# Tcl autoload index file: each line identifies a Tcl"} {
193                    while {[gets $f line] >= 0} {
194                        if {([string index $line 0] == "#")
195                                || ([llength $line] != 2)} {
196                            continue
197                        }
198                        set name [lindex $line 0]
199                        set auto_index($name) \
200                            "source [file join $dir [lindex $line 1]]"
201                    }
202                } else {
203                    error \
204                      "[file join $dir tclIndex] isn't a proper Tcl index file"
205                }
206            } msg]
207            if {$f != ""} {
208                close $f
209            }
210            if {$error} {
211                error $msg $errorInfo $errorCode
212            }
213        }
214    }
215    return 1
216}
217
218# auto_qualify --
219# compute a fully qualified names list for use in the auto_index array.
220# For historical reasons, commands in the global namespace do not have leading
221# :: in the index key. The list has two elements when the command name is
222# relative (no leading ::) and the namespace is not the global one. Otherwise
223# only one name is returned (and searched in the auto_index).
224#
225# Arguments -
226# cmd           The command name. Can be any name accepted for command
227#               invocations (Like "foo::::bar").
228# namespace     The namespace where the command is being used - must be
229#               a canonical namespace as returned by [namespace current]
230#               for instance.
231
232proc auto_qualify {cmd namespace} {
233
234    # count separators and clean them up
235    # (making sure that foo:::::bar will be treated as foo::bar)
236    set n [regsub -all {::+} $cmd :: cmd]
237
238    # Ignore namespace if the name starts with ::
239    # Handle special case of only leading ::
240
241    # Before each return case we give an example of which category it is
242    # with the following form :
243    # ( inputCmd, inputNameSpace) -> output
244
245    if {[regexp {^::(.*)$} $cmd x tail]} {
246        if {$n > 1} {
247            # ( ::foo::bar , * ) -> ::foo::bar
248            return [list $cmd]
249        } else {
250            # ( ::global , * ) -> global
251            return [list $tail]
252        }
253    }
254   
255    # Potentially returning 2 elements to try  :
256    # (if the current namespace is not the global one)
257
258    if {$n == 0} {
259        if {[string compare $namespace ::] == 0} {
260            # ( nocolons , :: ) -> nocolons
261            return [list $cmd]
262        } else {
263            # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
264            return [list ${namespace}::$cmd $cmd]
265        }
266    } else {
267        if {[string compare $namespace ::] == 0} {
268            #  ( foo::bar , :: ) -> ::foo::bar
269            return [list ::$cmd]
270        } else {
271            # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
272            return [list ${namespace}::$cmd ::$cmd]
273        }
274    }
275}
276
277# auto_import --
278# invoked during "namespace import" to make see if the imported commands
279# reside in an autoloaded library.  If so, the commands are loaded so
280# that they will be available for the import links.  If not, then this
281# procedure does nothing.
282#
283# Arguments -
284# pattern       The pattern of commands being imported (like "foo::*")
285#               a canonical namespace as returned by [namespace current]
286
287proc auto_import {pattern} {
288    global auto_index
289
290    set ns [uplevel namespace current]
291    set patternList [auto_qualify $pattern $ns]
292
293    auto_load_index
294
295    foreach pattern $patternList {
296        foreach name [array names auto_index] {
297            if {[string match $pattern $name] && "" == [info commands $name]} {
298                uplevel #0 $auto_index($name)
299            }
300        }
301    }
302}
303
304if {[string compare $tcl_platform(platform) windows] == 0} {
305
306# auto_execok --
307#
308# Returns string that indicates name of program to execute if
309# name corresponds to a shell builtin or an executable in the
310# Windows search path, or "" otherwise.  Builds an associative
311# array auto_execs that caches information about previous checks,
312# for speed.
313#
314# Arguments:
315# name -                        Name of a command.
316
317# Windows version.
318#
319# Note that info executable doesn't work under Windows, so we have to
320# look for files with .exe, .com, or .bat extensions.  Also, the path
321# may be in the Path or PATH environment variables, and path
322# components are separated with semicolons, not colons as under Unix.
323#
324proc auto_execok name {
325    global auto_execs env tcl_platform
326
327    if {[info exists auto_execs($name)]} {
328        return $auto_execs($name)
329    }
330    set auto_execs($name) ""
331
332    if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename 
333            ren rmdir rd time type ver vol} $name] != -1} {
334        return [set auto_execs($name) [list $env(COMSPEC) /c $name]]
335    }
336
337    if {[llength [file split $name]] != 1} {
338        foreach ext {{} .com .exe .bat} {
339            set file ${name}${ext}
340            if {[file exists $file] && ![file isdirectory $file]} {
341                return [set auto_execs($name) [list $file]]
342            }
343        }
344        return ""
345    }
346
347    set path "[file dirname [info nameof]];.;"
348    if {[info exists env(WINDIR)]} {
349        set windir $env(WINDIR)
350    }
351    if {[info exists windir]} {
352        if {$tcl_platform(os) == "Windows NT"} {
353            append path "$windir/system32;"
354        }
355        append path "$windir/system;$windir;"
356    }
357
358    if {[info exists env(PATH)]} {
359        append path $env(PATH)
360    }
361
362    foreach dir [split $path {;}] {
363        if {$dir == ""} {
364            set dir .
365        }
366        foreach ext {{} .com .exe .bat} {
367            set file [file join $dir ${name}${ext}]
368            if {[file exists $file] && ![file isdirectory $file]} {
369                return [set auto_execs($name) [list $file]]
370            }
371        }
372    }
373    return ""
374}
375
376} else {
377
378# auto_execok --
379#
380# Returns string that indicates name of program to execute if
381# name corresponds to an executable in the path. Builds an associative
382# array auto_execs that caches information about previous checks,
383# for speed.
384#
385# Arguments:
386# name -                        Name of a command.
387
388# Unix version.
389#
390proc auto_execok name {
391    global auto_execs env
392
393    if {[info exists auto_execs($name)]} {
394        return $auto_execs($name)
395    }
396    set auto_execs($name) ""
397    if {[llength [file split $name]] != 1} {
398        if {[file executable $name] && ![file isdirectory $name]} {
399            set auto_execs($name) [list $name]
400        }
401        return $auto_execs($name)
402    }
403    foreach dir [split $env(PATH) :] {
404        if {$dir == ""} {
405            set dir .
406        }
407        set file [file join $dir $name]
408        if {[file executable $file] && ![file isdirectory $file]} {
409            set auto_execs($name) [list $file]
410            return $auto_execs($name)
411        }
412    }
413    return ""
414}
415
416}
417# auto_reset --
418# Destroy all cached information for auto-loading and auto-execution,
419# so that the information gets recomputed the next time it's needed.
420# Also delete any procedures that are listed in the auto-load index
421# except those defined in this file.
422#
423# Arguments:
424# None.
425
426proc auto_reset {} {
427    global auto_execs auto_index auto_oldpath
428    foreach p [info procs] {
429        if {[info exists auto_index($p)] && ![string match auto_* $p]
430                && ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup tcl_findLibrary
431                        tclMacPkgSearch tclPkgUnknown} $p] < 0)} {
432            rename $p {}
433        }
434    }
435    catch {unset auto_execs}
436    catch {unset auto_index}
437    catch {unset auto_oldpath}
438}
439
440# tcl_findLibrary
441#       This is a utility for extensions that searches for a library directory
442#       using a canonical searching algorithm. A side effect is to source
443#       the initialization script and set a global library variable.
444# Arguments:
445#       basename        Prefix of the directory name, (e.g., "tk")
446#       version         Version number of the package, (e.g., "8.0")
447#       patch           Patchlevel of the package, (e.g., "8.0.3")
448#       initScript      Initialization script to source (e.g., tk.tcl)
449#       enVarName       environment variable to honor (e.g., TK_LIBRARY)
450#       varName         Global variable to set when done (e.g., tk_library)
451
452proc tcl_findLibrary {basename version patch initScript enVarName varName} {
453    upvar #0 $varName the_library
454    global env
455
456    set dirs {}
457    set errors {}
458
459    # The C application may have hardwired a path, which we honor
460   
461    if {[info exist the_library]} {
462        lappend dirs $the_library
463    } else {
464
465        # Do the canonical search
466
467        # 1. From an environment variable, if it exists
468
469        if {[info exists env($enVarName)]} {
470            lappend dirs $env($enVarName)
471        }
472
473        # 2. Relative to the Tcl library
474
475        lappend dirs [file join [file dirname [info library]] $basename$version]
476
477        # 3. Various locations relative to the executable
478        # ../lib/foo1.0         (From bin directory in install hierarchy)
479        # ../../lib/foo1.0      (From bin/arch directory in install hierarchy)
480        # ../library            (From unix directory in build hierarchy)
481        # ../../library         (From unix/arch directory in build hierarchy)
482        # ../../foo1.0b1/library (From unix directory in parallel build hierarchy)
483        # ../../../foo1.0b1/library (From unix/arch directory in parallel build hierarchy)
484
485        set parentDir [file dirname [file dirname [info nameofexecutable]]]
486        set grandParentDir [file dirname $parentDir]
487        lappend dirs [file join $parentDir lib $basename$version]
488        lappend dirs [file join $grandParentDir lib $basename$version]
489        lappend dirs [file join $parentDir library]
490        lappend dirs [file join $grandParentDir library]
491        if [string match {*[ab]*} $patch] {
492            set ver $patch
493        } else {
494            set ver $version
495        }
496        lappend dirs [file join $grandParentDir] $basename$ver library]
497        lappend dirs [file join [file dirname $grandParentDir] $basename$ver library]
498    }
499    foreach i $dirs {
500        set the_library $i
501        set file [file join $i $initScript]
502
503        # source everything when in a safe interpreter because
504        # we have a source command, but no file exists command
505
506        if {[interp issafe] || [file exists $file]} {
507            if {![catch {uplevel #0 [list source $file]} msg]} {
508                return
509            } else {
510                append errors "$file: $msg\n$errorInfo\n"
511            }
512        }
513    }
514    set msg "Can't find a usable $initScript in the following directories: \n"
515    append msg "    $dirs\n\n"
516    append msg "$errors\n\n"
517    append msg "This probably means that $basename wasn't installed properly.\n"
518    error $msg
519}
520
521
522# OPTIONAL SUPPORT PROCEDURES
523# In Tcl 8.1 all the code below here has been moved to other files to
524# reduce the size of init.tcl
525
526# ----------------------------------------------------------------------
527# auto_mkindex
528# ----------------------------------------------------------------------
529# The following procedures are used to generate the tclIndex file
530# from Tcl source files.  They use a special safe interpreter to
531# parse Tcl source files, writing out index entries as "proc"
532# commands are encountered.  This implementation won't work in a
533# safe interpreter, since a safe interpreter can't create the
534# special parser and mess with its commands.  If this is a safe
535# interpreter, we simply clip these procs out.
536
537if {[interp issafe]} {
538    proc auto_mkindex {dir args} {
539        error "can't generate index within safe interpreter"
540    }
541    proc tcl_nonsafe {args} {}
542} else {
543    proc tcl_nonsafe {args} {eval $args}
544}
545
546# auto_mkindex --
547# Regenerate a tclIndex file from Tcl source files.  Takes as argument
548# the name of the directory in which the tclIndex file is to be placed,
549# followed by any number of glob patterns to use in that directory to
550# locate all of the relevant files.
551#
552# Arguments:
553# dir -         Name of the directory in which to create an index.
554# args -        Any number of additional arguments giving the
555#               names of files within dir.  If no additional
556#               are given auto_mkindex will look for *.tcl.
557
558tcl_nonsafe proc auto_mkindex {dir args} {
559    global errorCode errorInfo
560
561    if {[interp issafe]} {
562        error "can't generate index within safe interpreter"
563    }
564
565    set oldDir [pwd]
566    cd $dir
567    set dir [pwd]
568
569    append index "# Tcl autoload index file, version 2.0\n"
570    append index "# This file is generated by the \"auto_mkindex\" command\n"
571    append index "# and sourced to set up indexing information for one or\n"
572    append index "# more commands.  Typically each line is a command that\n"
573    append index "# sets an element in the auto_index array, where the\n"
574    append index "# element name is the name of a command and the value is\n"
575    append index "# a script that loads the command.\n\n"
576    if {$args == ""} {
577        set args *.tcl
578    }
579    auto_mkindex_parser::init
580    foreach file [eval glob $args] {
581        if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {
582            append index $msg
583        } else {
584            set code $errorCode
585            set info $errorInfo
586            cd $oldDir
587            error $msg $info $code
588        }
589    }
590    auto_mkindex_parser::cleanup
591
592    set fid [open "tclIndex" w]
593    puts $fid $index nonewline
594    close $fid
595    cd $oldDir
596}
597
598# Original version of auto_mkindex that just searches the source
599# code for "proc" at the beginning of the line.
600
601proc auto_mkindex_old {dir args} {
602    global errorCode errorInfo
603    set oldDir [pwd]
604    cd $dir
605    set dir [pwd]
606    append index "# Tcl autoload index file, version 2.0\n"
607    append index "# This file is generated by the \"auto_mkindex\" command\n"
608    append index "# and sourced to set up indexing information for one or\n"
609    append index "# more commands.  Typically each line is a command that\n"
610    append index "# sets an element in the auto_index array, where the\n"
611    append index "# element name is the name of a command and the value is\n"
612    append index "# a script that loads the command.\n\n"
613    if {$args == ""} {
614        set args *.tcl
615    }
616    foreach file [eval glob $args] {
617        set f ""
618        set error [catch {
619            set f [open $file]
620            while {[gets $f line] >= 0} {
621                if {[regexp {^proc[     ]+([^   ]*)} $line match procName]} {
622                    set procName [lindex [auto_qualify $procName "::"] 0]
623                    append index "set [list auto_index($procName)]"
624                    append index " \[list source \[file join \$dir [list $file]\]\]\n"
625                }
626            }
627            close $f
628        } msg]
629        if {$error} {
630            set code $errorCode
631            set info $errorInfo
632            catch {close $f}
633            cd $oldDir
634            error $msg $info $code
635        }
636    }
637    set f ""
638    set error [catch {
639        set f [open tclIndex w]
640        puts $f $index nonewline
641        close $f
642        cd $oldDir
643    } msg]
644    if {$error} {
645        set code $errorCode
646        set info $errorInfo
647        catch {close $f}
648        cd $oldDir
649        error $msg $info $code
650    }
651}
652
653# Create a safe interpreter that can be used to parse Tcl source files
654# generate a tclIndex file for autoloading.  This interp contains
655# commands for things that need index entries.  Each time a command
656# is executed, it writes an entry out to the index file.
657
658namespace eval auto_mkindex_parser {
659    variable parser ""          ;# parser used to build index
660    variable index ""           ;# maintains index as it is built
661    variable scriptFile ""      ;# name of file being processed
662    variable contextStack ""    ;# stack of namespace scopes
663    variable imports ""         ;# keeps track of all imported cmds
664    variable initCommands ""    ;# list of commands that create aliases
665    proc init {} {
666        variable parser
667        variable initCommands
668        if {![interp issafe]} {
669            set parser [interp create -safe]
670            $parser hide info
671            $parser hide rename
672            $parser hide proc
673            $parser hide namespace
674            $parser hide eval
675            $parser hide puts
676            $parser invokehidden namespace delete ::
677            $parser invokehidden proc unknown {args} {}
678
679            #
680            # We'll need access to the "namespace" command within the
681            # interp.  Put it back, but move it out of the way.
682            #
683            $parser expose namespace
684            $parser invokehidden rename namespace _%@namespace
685            $parser expose eval
686            $parser invokehidden rename eval _%@eval
687
688            # Install all the registered psuedo-command implementations
689
690            foreach cmd $initCommands {
691                eval $cmd
692            }
693        }
694    }
695    proc cleanup {} {
696        variable parser
697        interp delete $parser
698        unset parser
699    }
700}
701
702# auto_mkindex_parser::mkindex --
703# Used by the "auto_mkindex" command to create a "tclIndex" file for
704# the given Tcl source file.  Executes the commands in the file, and
705# handles things like the "proc" command by adding an entry for the
706# index file.  Returns a string that represents the index file.
707#
708# Arguments:
709# file -                Name of Tcl source file to be indexed.
710
711tcl_nonsafe proc auto_mkindex_parser::mkindex {file} {
712    variable parser
713    variable index
714    variable scriptFile
715    variable contextStack
716    variable imports
717
718    set scriptFile $file
719
720    set fid [open $file]
721    set contents [read $fid]
722    close $fid
723
724    # There is one problem with sourcing files into the safe
725    # interpreter:  references like "$x" will fail since code is not
726    # really being executed and variables do not really exist.
727    # Be careful to escape all naked "$" before evaluating.
728
729    regsub -all {([^\$])\$([^\$])} $contents {\1\\$\2} contents
730
731    set index ""
732    set contextStack ""
733    set imports ""
734
735    $parser eval $contents
736
737    foreach name $imports {
738        catch {$parser eval [list _%@namespace forget $name]}
739    }
740    return $index
741}
742
743# auto_mkindex_parser::hook command
744# Registers a Tcl command to evaluate when initializing the
745# slave interpreter used by the mkindex parser.
746# The command is evaluated in the master interpreter, and can
747# use the variable auto_mkindex_parser::parser to get to the slave
748
749tcl_nonsafe proc auto_mkindex_parser::hook {cmd} {
750    variable initCommands
751
752    lappend initCommands $cmd
753}
754
755# auto_mkindex_parser::slavehook command
756# Registers a Tcl command to evaluate when initializing the
757# slave interpreter used by the mkindex parser.
758# The command is evaluated in the slave interpreter.
759
760tcl_nonsafe proc auto_mkindex_parser::slavehook {cmd} {
761    variable initCommands
762
763    lappend initCommands "\$parser eval [list $cmd]"
764}
765
766# auto_mkindex_parser::command --
767# Registers a new command with the "auto_mkindex_parser" interpreter
768# that parses Tcl files.  These commands are fake versions of things
769# like the "proc" command.  When you execute them, they simply write
770# out an entry to a "tclIndex" file for auto-loading.
771#
772# This procedure allows extensions to register their own commands
773# with the auto_mkindex facility.  For example, a package like
774# [incr Tcl] might register a "class" command so that class definitions
775# could be added to a "tclIndex" file for auto-loading.
776#
777# Arguments:
778# name -                Name of command recognized in Tcl files.
779# arglist -             Argument list for command.
780# body -                Implementation of command to handle indexing.
781
782tcl_nonsafe proc auto_mkindex_parser::command {name arglist body} {
783    hook [list auto_mkindex_parser::commandInit $name $arglist $body]
784}
785
786# auto_mkindex_parser::commandInit --
787# This does the actual work set up by auto_mkindex_parser::command
788# This is called when the interpreter used by the parser is created.
789
790tcl_nonsafe proc auto_mkindex_parser::commandInit {name arglist body} {
791    variable parser
792
793    set ns [namespace qualifiers $name]
794    set tail [namespace tail $name]
795    if {$ns == ""} {
796        set fakeName "[namespace current]::_%@fake_$tail"
797    } else {
798        set fakeName "_%@fake_$name"
799        regsub -all {::} $fakeName "_" fakeName
800        set fakeName "[namespace current]::$fakeName"
801    }
802    proc $fakeName $arglist $body
803
804    #
805    # YUK!  Tcl won't let us alias fully qualified command names,
806    # so we can't handle names like "::itcl::class".  Instead,
807    # we have to build procs with the fully qualified names, and
808    # have the procs point to the aliases.
809    #
810    if {[regexp {::} $name]} {
811        set exportCmd [list _%@namespace export [namespace tail $name]]
812        $parser eval [list _%@namespace eval $ns $exportCmd]
813        set alias [namespace tail $fakeName]
814        $parser invokehidden proc $name {args} "_%@eval $alias \$args"
815        $parser alias $alias $fakeName
816    } else {
817        $parser alias $name $fakeName
818    }
819    return
820}
821
822# auto_mkindex_parser::fullname --
823# Used by commands like "proc" within the auto_mkindex parser.
824# Returns the qualified namespace name for the "name" argument.
825# If the "name" does not start with "::", elements are added from
826# the current namespace stack to produce a qualified name.  Then,
827# the name is examined to see whether or not it should really be
828# qualified.  If the name has more than the leading "::", it is
829# returned as a fully qualified name.  Otherwise, it is returned
830# as a simple name.  That way, the Tcl autoloader will recognize
831# it properly.
832#
833# Arguments:
834# name -                Name that is being added to index.
835
836tcl_nonsafe proc auto_mkindex_parser::fullname {name} {
837    variable contextStack
838
839    if {![string match ::* $name]} {
840        foreach ns $contextStack {
841            set name "${ns}::$name"
842            if {[string match ::* $name]} {
843                break
844            }
845        }
846    }
847
848    if {[namespace qualifiers $name] == ""} {
849        return [namespace tail $name]
850    } elseif {![string match ::* $name]} {
851        return "::$name"
852    }
853    return $name
854}
855
856# Register all of the procedures for the auto_mkindex parser that
857# will build the "tclIndex" file.
858
859# AUTO MKINDEX:  proc name arglist body
860# Adds an entry to the auto index list for the given procedure name.
861
862tcl_nonsafe auto_mkindex_parser::command proc {name args} {
863    variable index
864    variable scriptFile
865    append index "set [list auto_index([fullname $name])]"
866    append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
867}
868
869# AUTO MKINDEX:  namespace eval name command ?arg arg...?
870# Adds the namespace name onto the context stack and evaluates the
871# associated body of commands.
872#
873# AUTO MKINDEX:  namespace import ?-force? pattern ?pattern...?
874# Performs the "import" action in the parser interpreter.  This is
875# important for any commands contained in a namespace that affect
876# the index.  For example, a script may say "itcl::class ...",
877# or it may import "itcl::*" and then say "class ...".  This
878# procedure does the import operation, but keeps track of imported
879# patterns so we can remove the imports later.
880
881tcl_nonsafe auto_mkindex_parser::command namespace {op args} {
882    switch -- $op {
883        eval {
884            variable parser
885            variable contextStack
886
887            set name [lindex $args 0]
888            set args [lrange $args 1 end]
889
890            set contextStack [linsert $contextStack 0 $name]
891            if {[llength $args] == 1} {
892                $parser eval [lindex $args 0]
893            } else {
894                eval $parser eval $args
895            }
896            set contextStack [lrange $contextStack 1 end]
897        }
898        import {
899            variable parser
900            variable imports
901            foreach pattern $args {
902                if {$pattern != "-force"} {
903                    lappend imports $pattern
904                }
905            }
906            catch {$parser eval "_%@namespace import $args"}
907        }
908    }
909}
910
911rename tcl_nonsafe ""
912
913# pkg_mkIndex --
914# This procedure creates a package index in a given directory.  The
915# package index consists of a "pkgIndex.tcl" file whose contents are
916# a Tcl script that sets up package information with "package require"
917# commands.  The commands describe all of the packages defined by the
918# files given as arguments.
919#
920# Arguments:
921# -direct               (optional) If this flag is present, the generated
922#                       code in pkgMkIndex.tcl will cause the package to be
923#                       loaded when "package require" is executed, rather
924#                       than lazily when the first reference to an exported
925#                       procedure in the package is made.
926# -nopkgrequire         (optional) If this flag is present, "package require"
927#                       commands are ignored. This flag is useful in some
928#                       situations, for example when there is a circularity
929#                       in package requires (package a requires package b,
930#                       which in turns requires package a).
931# -verbose              (optional) Verbose output; the name of each file that
932#                       was successfully rocessed is printed out. Additionally,
933#                       if processing of a file failed a message is printed
934#                       out; a file failure may not indicate that the indexing
935#                       has failed, since pkg_mkIndex stores the list of failed
936#                       files and tries again. The second time the processing
937#                       may succeed, for example if a required package has been
938#                       indexed by a previous pass.
939# dir -                 Name of the directory in which to create the index.
940# args -                Any number of additional arguments, each giving
941#                       a glob pattern that matches the names of one or
942#                       more shared libraries or Tcl script files in
943#                       dir.
944
945proc pkg_mkIndex {args} {
946    global errorCode errorInfo
947    set usage {"pkg_mkIndex ?-nopkgrequire? ?-direct? ?-verbose? dir ?pattern ...?"};
948
949    set argCount [llength $args]
950    if {$argCount < 1} {
951        return -code error "wrong # args: should be\n$usage"
952    }
953
954    set more ""
955    set direct 0
956    set noPkgRequire 0
957    set doVerbose 0
958    for {set idx 0} {$idx < $argCount} {incr idx} {
959        set flag [lindex $args $idx]
960        switch -glob -- $flag {
961            -- {
962                # done with the flags
963                incr idx
964                break
965            }
966
967            -verbose {
968                set doVerbose 1
969            }
970
971            -direct {
972                set direct 1
973                append more " -direct"
974            }
975
976            -nopkgrequire {
977                set noPkgRequire 1
978                append more " -nopkgrequire"
979            }
980
981            -* {
982                return -code error "unknown flag $flag: should be\n$usage"
983            }
984
985            default {
986                # done with the flags
987                break
988            }
989        }
990    }
991
992    set dir [lindex $args $idx]
993    set patternList [lrange $args [expr $idx + 1] end]
994    if {[llength $patternList] == 0} {
995        set patternList [list "*.tcl" "*[info sharedlibextension]"]
996    }
997
998    append index "# Tcl package index file, version 1.1\n"
999    append index "# This file is generated by the \"pkg_mkIndex$more\" command\n"
1000    append index "# and sourced either when an application starts up or\n"
1001    append index "# by a \"package unknown\" script.  It invokes the\n"
1002    append index "# \"package ifneeded\" command to set up package-related\n"
1003    append index "# information so that packages will be loaded automatically\n"
1004    append index "# in response to \"package require\" commands.  When this\n"
1005    append index "# script is sourced, the variable \$dir must contain the\n"
1006    append index "# full path name of this file's directory.\n"
1007    set oldDir [pwd]
1008    cd $dir
1009
1010    # In order to support building of index files from scratch, we make
1011    # repeated passes on the files to index, until either all have been
1012    # indexed, or we can no longer make any headway.
1013
1014    foreach file [eval glob $patternList] {
1015        set toProcess($file) 1
1016    }
1017
1018    while {[array size toProcess] > 0} {
1019        set processed 0
1020
1021        foreach file [array names toProcess] {
1022            # For each file, figure out what commands and packages it provides.
1023            # To do this, create a child interpreter, load the file into the
1024            # interpreter, and get a list of the new commands and packages
1025            # that are defined. The interpeter uses a special version of
1026            # tclPkgSetup to force loading of required packages at require
1027            # time rather than lazily, so that we can keep track of commands
1028            # and packages that are defined indirectly rather than from the
1029            # file itself.
1030
1031            set c [interp create]
1032
1033            # Load into the child all packages currently loaded in the parent
1034            # interpreter, in case the extension depends on some of them.
1035
1036            foreach pkg [info loaded] {
1037                if {[lindex $pkg 1] == "Tk"} {
1038                    $c eval {set argv {-geometry +0+0}}
1039                }
1040                load [lindex $pkg 0] [lindex $pkg 1] $c
1041            }
1042
1043            # We also call package ifneeded for all packages that have been
1044            # identified so far. This way, each pass will have loaded the
1045            # equivalent of the pkgIndex.tcl file that we are constructing,
1046            # and packages whose processing failed in previous passes may
1047            # be processed successfully now
1048
1049            foreach pkg [array names files] {
1050                $c eval "package ifneeded $pkg\
1051                        \[list tclPkgSetup $dir \
1052                        [lrange $pkg 0 0] [lrange $pkg 1 1]\
1053                        [list $files($pkg)]\]"
1054            }
1055            if {$noPkgRequire == 1} {
1056                $c eval {
1057                    rename package __package_orig
1058                    proc package {what args} {
1059                        switch -- $what {
1060                            require { return ; # ignore transitive requires }
1061                            default { eval __package_orig {$what} $args }
1062                        }
1063                    }
1064                    proc __dummy args {}
1065                    package unknown __dummy
1066                }
1067            } else {
1068                $c eval {
1069                    rename package __package_orig
1070                    proc package {what args} {
1071                        switch -- $what {
1072                            require {
1073                                eval __package_orig require $args
1074
1075                                # a package that was required needs to be
1076                                # placed in the list of packages to ignore.
1077                                # tclPkgSetup is unable to do it, so do it
1078                                # here.
1079
1080                                set ::__ignorePkgs([lindex $args 0]) 1
1081                            }
1082
1083                            provide {
1084                                # if package provide is called at level 1 and
1085                                # with two arguments, then this package is
1086                                # being provided by one of the files we are
1087                                # indexing, and therefore we need to add it
1088                                # to the list of packages to write out.
1089                                # We need to do this check because otherwise
1090                                # packages that are spread over multiple
1091                                # files are indexed only by their first file
1092                                # loaded.
1093                                # Note that packages that this cannot catch
1094                                # packages that are implemented by a
1095                                # combination of TCL files and DLLs
1096
1097                                if {([info level] == 1) \
1098                                        && ([llength $args] == 2)} {
1099                                    lappend ::__providedPkgs [lindex $args 0]
1100                                }
1101
1102                                eval __package_orig provide $args
1103                            }
1104
1105                            default { eval __package_orig {$what} $args }
1106                        }
1107                    }
1108                }
1109            }
1110
1111            $c eval [list set __file $file]
1112            $c eval [list set __direct $direct]
1113            if {[catch {
1114                $c eval {
1115                    set __doingWhat "loading or sourcing"
1116
1117                    # override the tclPkgSetup procedure (which is called by
1118                    # package ifneeded statements from pkgIndex.tcl) to force
1119                    # loads of packages, and also keep track of
1120                    # packages/namespaces/commands that the load generated
1121
1122                    proc tclPkgSetup {dir pkg version files} {
1123                        # remember the current set of packages and commands,
1124                        # so that we can add any that were defined by the
1125                        # package files to the list of packages and commands
1126                        # to ignore
1127
1128                        foreach __p [package names] {
1129                            set __localIgnorePkgs($__p) 1
1130                        }
1131                        foreach __ns [__pkgGetAllNamespaces] {
1132                            set __localIgnoreNs($__ns) 1
1133
1134                            # if the namespace is already in the __ignoreNs
1135                            # array, its commands have already been imported
1136
1137                            if {[info exists ::__ignoreNs($__ns)] == 0} {
1138                                namespace import ${__ns}::*
1139                            }
1140                        }
1141                        foreach __cmd [info commands] {
1142                            set __localIgnoreCmds($__cmd) 1
1143                        }
1144                       
1145                        # load the files that make up the package
1146
1147                        package provide $pkg $version
1148                        foreach __fileInfo $files {
1149                            set __f [lindex $__fileInfo 0]
1150                            set __type [lindex $__fileInfo 1]
1151                            if {$__type == "load"} {
1152                                load [file join $dir $__f] $pkg
1153                            } else {
1154                                source [file join $dir $__f]
1155                            }
1156                        }
1157
1158                        # packages and commands that were defined by these
1159                        # files are to be ignored.
1160
1161                        foreach __p [package names] {
1162                            if {[info exists __localIgnorePkgs($__p)] == 0} {
1163                                set ::__ignorePkgs($__p) 1
1164                            }
1165                        }
1166                        foreach __ns [__pkgGetAllNamespaces] {
1167                            if {([info exists __localIgnoreNs($__ns)] == 0) \
1168                                && ([info exists ::__ignoreNs($__ns)] == 0)} {
1169                                namespace import ${__ns}::*
1170                                set ::__ignoreNs($__ns) 1
1171                            }
1172                        }
1173                        foreach __cmd [info commands] {
1174                            if {[info exists __localIgnoreCmds($__cmd)] == 0} {
1175                                lappend ::__ignoreCmds $__cmd
1176                            }
1177                        }
1178                    }
1179
1180                    # we need to track command defined by each package even in
1181                    # the -direct case, because they are needed internally by
1182                    # the "partial pkgIndex.tcl" step above.
1183
1184                    proc __pkgGetAllNamespaces {{root {}}} {
1185                        set __list $root
1186                        foreach __ns [namespace children $root] {
1187                            eval lappend __list [__pkgGetAllNamespaces $__ns]
1188                        }
1189                        return $__list
1190                    }
1191
1192                    # initialize the list of packages to ignore; these are
1193                    # packages that are present before the script/dll is loaded
1194
1195                    set ::__ignorePkgs(Tcl) 1
1196                    set ::__ignorePkgs(Tk) 1
1197                    foreach __pkg [package names] {
1198                        set ::__ignorePkgs($__pkg) 1
1199                    }
1200
1201                    # before marking the original commands, import all the
1202                    # namespaces that may have been loaded from the parent;
1203                    # these namespaces and their commands are to be ignored
1204
1205                    foreach __ns [__pkgGetAllNamespaces] {
1206                        set ::__ignoreNs($__ns) 1
1207                        namespace import ${__ns}::*
1208                    }
1209
1210                    set ::__ignoreCmds [info commands]
1211
1212                    set dir ""          ;# in case file is pkgIndex.tcl
1213
1214                    # Try to load the file if it has the shared library
1215                    # extension, otherwise source it.  It's important not to
1216                    # try to load files that aren't shared libraries, because
1217                    # on some systems (like SunOS) the loader will abort the
1218                    # whole application when it gets an error.
1219
1220                    set __pkgs {}
1221                    set __providedPkgs {}
1222                    if {[string compare [file extension $__file] \
1223                            [info sharedlibextension]] == 0} {
1224
1225                        # The "file join ." command below is necessary.
1226                        # Without it, if the file name has no \'s and we're
1227                        # on UNIX, the load command will invoke the
1228                        # LD_LIBRARY_PATH search mechanism, which could cause
1229                        # the wrong file to be used.
1230
1231                        set __doingWhat loading
1232                        load [file join . $__file]
1233                        set __type load
1234                    } else {
1235                        set __doingWhat sourcing
1236                        source $__file
1237                        set __type source
1238                    }
1239
1240                    # Using __ variable names to avoid potential namespaces
1241                    # clash, even here in post processing because the
1242                    # loaded package could have set up traces,...
1243
1244                    foreach __ns [__pkgGetAllNamespaces] {
1245                        if {[info exists ::__ignoreNs($__ns)] == 0} {
1246                            namespace import ${__ns}::*
1247                        }
1248                    }
1249                    foreach __i [info commands] {
1250                        set __cmds($__i) 1
1251                    }
1252                    foreach __i $::__ignoreCmds {
1253                        catch {unset __cmds($__i)}
1254                    }
1255                    foreach __i [array names __cmds] {
1256                        # reverse engineer which namespace a command comes from
1257                       
1258                        set __absolute [namespace origin $__i]
1259
1260                        # special case so that global names have no leading
1261                        # ::, this is required by the unknown command
1262
1263                        set __absolute [auto_qualify $__absolute ::]
1264
1265                        if {[string compare $__i $__absolute] != 0} {
1266                            set __cmds($__absolute) 1
1267                            unset __cmds($__i)
1268                        }
1269                    }
1270
1271                    foreach __i $::__providedPkgs {
1272                        lappend __pkgs [list $__i [package provide $__i]]
1273                        set __ignorePkgs($__i) 1
1274                    }
1275                    foreach __i [package names] {
1276                        if {([string compare [package provide $__i] ""] != 0) \
1277                                && ([info exists ::__ignorePkgs($__i)] == 0)} {
1278                            lappend __pkgs [list $__i [package provide $__i]]
1279                        }
1280                    }
1281                }
1282            } msg] == 1} {
1283                set what [$c eval set __doingWhat]
1284                if {$doVerbose} {
1285                    tclLog "warning: error while $what $file: $msg\nthis file will be retried in the next pass"
1286                }
1287            } else {
1288                set type [$c eval set __type]
1289                set cmds [lsort [$c eval array names __cmds]]
1290                set pkgs [$c eval set __pkgs]
1291                if {[llength $pkgs] > 1} {
1292                    tclLog "warning: \"$file\" provides more than one package ($pkgs)"
1293                }
1294                foreach pkg $pkgs {
1295                    # cmds is empty/not used in the direct case
1296                    lappend files($pkg) [list $file $type $cmds]
1297                }
1298
1299                incr processed
1300                unset toProcess($file)
1301
1302                if {$doVerbose} {
1303                    tclLog "processed $file"
1304                }
1305            }
1306            interp delete $c
1307        }
1308
1309        if {$processed == 0} {
1310            tclLog "this iteration could not process any files: giving up here"
1311            break
1312        }
1313    }
1314
1315    foreach pkg [lsort [array names files]] {
1316        append index "\npackage ifneeded $pkg "
1317        if {$direct} {
1318            set cmdList {}
1319            foreach elem $files($pkg) {
1320                set file [lindex $elem 0]
1321                set type [lindex $elem 1]
1322                lappend cmdList "\[list $type \[file join \$dir\
1323                        [list $file]\]\]"
1324            }
1325            append index [join $cmdList "\\n"]
1326        } else {
1327            append index "\[list tclPkgSetup \$dir [lrange $pkg 0 0]\
1328                    [lrange $pkg 1 1] [list $files($pkg)]\]"
1329        }
1330    }
1331    set f [open pkgIndex.tcl w]
1332    puts $f $index
1333    close $f
1334    cd $oldDir
1335}
1336
1337# tclPkgSetup --
1338# This is a utility procedure use by pkgIndex.tcl files.  It is invoked
1339# as part of a "package ifneeded" script.  It calls "package provide"
1340# to indicate that a package is available, then sets entries in the
1341# auto_index array so that the package's files will be auto-loaded when
1342# the commands are used.
1343#
1344# Arguments:
1345# dir -                 Directory containing all the files for this package.
1346# pkg -                 Name of the package (no version number).
1347# version -             Version number for the package, such as 2.1.3.
1348# files -               List of files that constitute the package.  Each
1349#                       element is a sub-list with three elements.  The first
1350#                       is the name of a file relative to $dir, the second is
1351#                       "load" or "source", indicating whether the file is a
1352#                       loadable binary or a script to source, and the third
1353#                       is a list of commands defined by this file.
1354
1355proc tclPkgSetup {dir pkg version files} {
1356    global auto_index
1357
1358    package provide $pkg $version
1359    foreach fileInfo $files {
1360        set f [lindex $fileInfo 0]
1361        set type [lindex $fileInfo 1]
1362        foreach cmd [lindex $fileInfo 2] {
1363            if {$type == "load"} {
1364                set auto_index($cmd) [list load [file join $dir $f] $pkg]
1365            } else {
1366                set auto_index($cmd) [list source [file join $dir $f]]
1367            }
1368        }
1369    }
1370}
1371
1372# tclMacPkgSearch --
1373# The procedure is used on the Macintosh to search a given directory for files
1374# with a TEXT resource named "pkgIndex".  If it exists it is sourced in to the
1375# interpreter to setup the package database.
1376
1377proc tclMacPkgSearch {dir} {
1378    foreach x [glob -nocomplain [file join $dir *.shlb]] {
1379        if {[file isfile $x]} {
1380            set res [resource open $x]
1381            foreach y [resource list TEXT $res] {
1382                if {$y == "pkgIndex"} {source -rsrc pkgIndex}
1383            }
1384            catch {resource close $res}
1385        }
1386    }
1387}
1388
1389# tclPkgUnknown --
1390# This procedure provides the default for the "package unknown" function.
1391# It is invoked when a package that's needed can't be found.  It scans
1392# the auto_path directories and their immediate children looking for
1393# pkgIndex.tcl files and sources any such files that are found to setup
1394# the package database.  (On the Macintosh we also search for pkgIndex
1395# TEXT resources in all files.)
1396#
1397# Arguments:
1398# name -                Name of desired package.  Not used.
1399# version -             Version of desired package.  Not used.
1400# exact -               Either "-exact" or omitted.  Not used.
1401
1402proc tclPkgUnknown {name version {exact {}}} {
1403    # We don't do auto-loading, so this is disabled... (csp)
1404    return
1405
1406    global auto_path tcl_platform env
1407
1408    if {![info exists auto_path]} {
1409        return
1410    }
1411    for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
1412        # we can't use glob in safe interps, so enclose the following
1413        # in a catch statement
1414        catch {
1415            foreach file [glob -nocomplain [file join [lindex $auto_path $i] \
1416                    * pkgIndex.tcl]] {
1417                set dir [file dirname $file]
1418                if {[catch {source $file} msg]} {
1419                    tclLog "error reading package index file $file: $msg"
1420                }
1421            }
1422        }
1423        set dir [lindex $auto_path $i]
1424        set file [file join $dir pkgIndex.tcl]
1425        # safe interps usually don't have "file readable", nor stderr channel
1426        if {[interp issafe] || [file readable $file]} {
1427            if {[catch {source $file} msg] && ![interp issafe]}  {
1428                tclLog "error reading package index file $file: $msg"
1429            }
1430        }
1431        # On the Macintosh we also look in the resource fork
1432        # of shared libraries
1433        # We can't use tclMacPkgSearch in safe interps because it uses glob
1434        if {(![interp issafe]) && ($tcl_platform(platform) == "macintosh")} {
1435            set dir [lindex $auto_path $i]
1436            tclMacPkgSearch $dir
1437            foreach x [glob -nocomplain [file join $dir *]] {
1438                if {[file isdirectory $x]} {
1439                    set dir $x
1440                    tclMacPkgSearch $dir
1441                }
1442            }
1443        }
1444    }
1445}
Note: See TracBrowser for help on using the browser.