3 # utility procs formerly in init.tcl which can be loaded on demand
4 # for package management.
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.
13 namespace eval tcl
::Pkg {}
15 # ::tcl::Pkg::CompareExtension --
17 # Used internally by pkg_mkIndex to compare the extension of a file to
18 # a given extension. On Windows, it uses a case-insensitive comparison
19 # because the file system can be file insensitive.
22 # fileName name of a file whose extension is compared
23 # ext (optional) The extension to compare against; you must
24 # provide the starting dot.
25 # Defaults to [info sharedlibextension]
28 # Returns 1 if the extension matches, 0 otherwise
30 proc tcl
::Pkg::CompareExtension { fileName
{ext
{}} } {
32 if {$ext eq
""} {set ext
[info sharedlibextension
]}
33 if {$tcl_platform(platform
) eq
"windows"} {
34 return [string equal
-nocase [file extension
$fileName] $ext]
36 # Some unices add trailing numbers after the .so, so
37 # we could have something like '.so.1.2'.
40 set currExt
[file extension
$root]
41 if {$currExt eq
$ext} {
45 # The current extension does not match; if it is not a numeric
46 # value, quit, as we are only looking to ignore version number
47 # extensions. Otherwise we might return 1 in this case:
48 # tcl::Pkg::CompareExtension foo.so.bar .so
49 # which should not match.
51 if { ![string is integer
-strict [string range
$currExt 1 end
]] } {
54 set root
[file rootname
$root]
60 # This procedure creates a package index in a given directory. The
61 # package index consists of a "pkgIndex.tcl" file whose contents are
62 # a Tcl script that sets up package information with "package require"
63 # commands. The commands describe all of the packages defined by the
64 # files given as arguments.
67 # -direct (optional) If this flag is present, the generated
68 # code in pkgMkIndex.tcl will cause the package to be
69 # loaded when "package require" is executed, rather
70 # than lazily when the first reference to an exported
71 # procedure in the package is made.
72 # -verbose (optional) Verbose output; the name of each file that
73 # was successfully rocessed is printed out. Additionally,
74 # if processing of a file failed a message is printed.
75 # -load pat (optional) Preload any packages whose names match
76 # the pattern. Used to handle DLLs that depend on
77 # other packages during their Init procedure.
78 # dir - Name of the directory in which to create the index.
79 # args - Any number of additional arguments, each giving
80 # a glob pattern that matches the names of one or
81 # more shared libraries or Tcl script files in
84 proc pkg_mkIndex {args
} {
85 set usage
{"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"};
87 set argCount
[llength $args]
89 return -code error "wrong # args: should be\n$usage"
96 for {set idx
0} {$idx < $argCount} {incr idx
} {
97 set flag
[lindex $args $idx]
98 switch -glob -- $flag {
100 # done with the flags
112 append more
" -direct"
116 set loadPat
[lindex $args $idx]
117 append more
" -load $loadPat"
120 return -code error "unknown flag $flag: should be\n$usage"
123 # done with the flags
129 set dir
[lindex $args $idx]
130 set patternList
[lrange $args [expr {$idx + 1}] end
]
131 if {[llength $patternList] == 0} {
132 set patternList
[list "*.tcl" "*[info sharedlibextension]"]
136 glob -directory $dir -tails -types {r f
} -- {*}$patternList
138 return -options $o $fileList
140 foreach file $fileList {
141 # For each file, figure out what commands and packages it provides.
142 # To do this, create a child interpreter, load the file into the
143 # interpreter, and get a list of the new commands and packages
146 if {$file eq
"pkgIndex.tcl"} {
150 set c
[interp create
]
152 # Load into the child any packages currently loaded in the parent
153 # interpreter that match the -load pattern.
155 if {$loadPat ne
""} {
157 tclLog
"currently loaded packages: '[info loaded]'"
158 tclLog
"trying to load all packages matching $loadPat"
160 if {![llength [info loaded
]]} {
161 tclLog
"warning: no packages are currently loaded, nothing"
162 tclLog
"can possibly match '$loadPat'"
165 foreach pkg
[info loaded
] {
166 if {! [string match
-nocase $loadPat [lindex $pkg 1]]} {
170 tclLog
"package [lindex $pkg 1] matches '$loadPat'"
173 load [lindex $pkg 0] [lindex $pkg 1] $c
176 tclLog
"warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
178 } elseif
{$doVerbose} {
179 tclLog
"loaded [lindex $pkg 0] [lindex $pkg 1]"
181 if {[lindex $pkg 1] eq
"Tk"} {
182 # Withdraw . if Tk was loaded, to avoid showing a window.
183 $c eval [list wm withdraw .
]
188 # Stub out the package command so packages can
189 # require other packages.
191 rename package __package_orig
192 proc package {what args
} {
194 require
{ return ; # ignore transitive requires }
195 default { __package_orig
$what {*}$args }
198 proc tclPkgUnknown args
{}
199 package unknown tclPkgUnknown
201 # Stub out the unknown command so package can call
202 # into each other during their initialilzation.
204 proc unknown {args
} {}
206 # Stub out the auto_import mechanism
208 proc auto_import {args
} {}
210 # reserve the ::tcl namespace for support procs
211 # and temporary variables. This might make it awkward
212 # to generate a pkgIndex.tcl file for the ::tcl namespace.
214 namespace eval ::tcl {
215 variable dir
;# Current directory being processed
216 variable file ;# Current file being processed
217 variable direct
;# -direct flag value
218 variable x
;# Loop variable
219 variable debug
;# For debugging
220 variable type
;# "load" or "source", for -direct
221 variable namespaces
;# Existing namespaces (e.g., ::tcl)
222 variable packages
;# Existing packages (e.g., Tcl)
223 variable origCmds
;# Existing commands
224 variable newCmds
;# Newly created commands
225 variable newPkgs
{} ;# Newly created packages
229 $c eval [list set ::tcl::dir $dir]
230 $c eval [list set ::tcl::file $file]
231 $c eval [list set ::tcl::direct $direct]
233 # Download needed procedures into the slave because we've
234 # just deleted the unknown procedure. This doesn't handle
235 # procedures with default arguments.
237 foreach p
{::tcl::Pkg::CompareExtension} {
238 $c eval [list namespace eval [namespace qualifiers
$p] {}]
239 $c eval [list proc $p [info args
$p] [info body
$p]]
244 set ::tcl::debug "loading or sourcing"
246 # we need to track command defined by each package even in
247 # the -direct case, because they are needed internally by
248 # the "partial pkgIndex.tcl" step above.
250 proc ::tcl::GetAllNamespaces {{root
::}} {
252 foreach ns
[namespace children
$root] {
253 lappend list {*}[::tcl::GetAllNamespaces $ns]
258 # init the list of existing namespaces, packages, commands
260 foreach ::tcl::x [::tcl::GetAllNamespaces] {
261 set ::tcl::namespaces($::tcl::x) 1
263 foreach ::tcl::x [package names
] {
264 if {[package provide
$::tcl::x] ne
""} {
265 set ::tcl::packages($::tcl::x) 1
268 set ::tcl::origCmds [info commands
]
270 # Try to load the file if it has the shared library
271 # extension, otherwise source it. It's important not to
272 # try to load files that aren't shared libraries, because
273 # on some systems (like SunOS) the loader will abort the
274 # whole application when it gets an error.
276 if {[::tcl::Pkg::CompareExtension $::tcl::file [info sharedlibextension
]]} {
277 # The "file join ." command below is necessary.
278 # Without it, if the file name has no \'s and we're
279 # on UNIX, the load command will invoke the
280 # LD_LIBRARY_PATH search mechanism, which could cause
281 # the wrong file to be used.
283 set ::tcl::debug loading
284 load [file join $::tcl::dir $::tcl::file]
287 set ::tcl::debug sourcing
288 source [file join $::tcl::dir $::tcl::file]
289 set ::tcl::type source
292 # As a performance optimization, if we are creating
293 # direct load packages, don't bother figuring out the
294 # set of commands created by the new packages. We
295 # only need that list for setting up the autoloading
296 # used in the non-direct case.
297 if { !$::tcl::direct } {
298 # See what new namespaces appeared, and import commands
299 # from them. Only exported commands go into the index.
301 foreach ::tcl::x [::tcl::GetAllNamespaces] {
302 if {! [info exists
::tcl::namespaces($::tcl::x)]} {
303 namespace import
-force ${::tcl::x}::*
306 # Figure out what commands appeared
308 foreach ::tcl::x [info commands
] {
309 set ::tcl::newCmds($::tcl::x) 1
311 foreach ::tcl::x $::tcl::origCmds {
312 unset -nocomplain ::tcl::newCmds($::tcl::x)
314 foreach ::tcl::x [array names
::tcl::newCmds] {
315 # determine which namespace a command comes from
317 set ::tcl::abs [namespace origin
$::tcl::x]
319 # special case so that global names have no leading
320 # ::, this is required by the unknown command
323 [lindex [auto_qualify $::tcl::abs ::] 0]
325 if {$::tcl::x ne
$::tcl::abs} {
326 # Name changed during qualification
328 set ::tcl::newCmds($::tcl::abs) 1
329 unset ::tcl::newCmds($::tcl::x)
335 # Look through the packages that appeared, and if there is
336 # a version provided, then record it
338 foreach ::tcl::x [package names
] {
339 if {[package provide
$::tcl::x] ne
""
340 && ![info exists
::tcl::packages($::tcl::x)]} {
341 lappend ::tcl::newPkgs \
342 [list $::tcl::x [package provide
$::tcl::x]]
347 set what
[$c eval set ::tcl::debug]
349 tclLog
"warning: error while $what $file: $msg"
352 set what
[$c eval set ::tcl::debug]
354 tclLog
"successful $what of $file"
356 set type
[$c eval set ::tcl::type]
357 set cmds
[lsort [$c eval array names
::tcl::newCmds]]
358 set pkgs
[$c eval set ::tcl::newPkgs]
361 tclLog
"commands provided were $cmds"
363 tclLog
"packages provided were $pkgs"
365 if {[llength $pkgs] > 1} {
366 tclLog
"warning: \"$file\" provides more than one package ($pkgs)"
369 # cmds is empty/not used in the direct case
370 lappend files
($pkg) [list $file $type $cmds]
374 tclLog
"processed $file"
380 append index
"# Tcl package index file, version 1.1\n"
381 append index
"# This file is generated by the \"pkg_mkIndex$more\" command\n"
382 append index
"# and sourced either when an application starts up or\n"
383 append index
"# by a \"package unknown\" script. It invokes the\n"
384 append index
"# \"package ifneeded\" command to set up package-related\n"
385 append index
"# information so that packages will be loaded automatically\n"
386 append index
"# in response to \"package require\" commands. When this\n"
387 append index
"# script is sourced, the variable \$dir must contain the\n"
388 append index
"# full path name of this file's directory.\n"
390 foreach pkg
[lsort [array names files
]] {
392 foreach {name version
} $pkg {
395 lappend cmd
::tcl::Pkg::Create -name $name -version $version
396 foreach spec
[lsort -index 0 $files($pkg)] {
397 foreach {file type procs
} $spec {
401 lappend cmd
"-$type" [list $file $procs]
404 append index
"\n[eval $cmd]"
407 set f
[open [file join $dir pkgIndex.tcl
] w
]
413 # This is a utility procedure use by pkgIndex.tcl files. It is invoked
414 # as part of a "package ifneeded" script. It calls "package provide"
415 # to indicate that a package is available, then sets entries in the
416 # auto_index array so that the package's files will be auto-loaded when
417 # the commands are used.
420 # dir - Directory containing all the files for this package.
421 # pkg - Name of the package (no version number).
422 # version - Version number for the package, such as 2.1.3.
423 # files - List of files that constitute the package. Each
424 # element is a sub-list with three elements. The first
425 # is the name of a file relative to $dir, the second is
426 # "load" or "source", indicating whether the file is a
427 # loadable binary or a script to source, and the third
428 # is a list of commands defined by this file.
430 proc tclPkgSetup
{dir pkg version files
} {
433 package provide
$pkg $version
434 foreach fileInfo
$files {
435 set f
[lindex $fileInfo 0]
436 set type
[lindex $fileInfo 1]
437 foreach cmd
[lindex $fileInfo 2] {
438 if {$type eq
"load"} {
439 set auto_index
($cmd) [list load [file join $dir $f] $pkg]
441 set auto_index
($cmd) [list source [file join $dir $f]]
448 # This procedure provides the default for the "package unknown" function.
449 # It is invoked when a package that's needed can't be found. It scans
450 # the auto_path directories and their immediate children looking for
451 # pkgIndex.tcl files and sources any such files that are found to setup
452 # the package database. As it searches, it will recognize changes
453 # to the auto_path and scan any new directories.
456 # name - Name of desired package. Not used.
457 # version - Version of desired package. Not used.
458 # exact - Either "-exact" or omitted. Not used.
460 proc tclPkgUnknown
{name args
} {
463 if {![info exists auto_path
]} {
466 # Cache the auto_path, because it may change while we run through
467 # the first set of pkgIndex.tcl files
468 set old_path
[set use_path
$auto_path]
469 while {[llength $use_path]} {
470 set dir
[lindex $use_path end
]
472 # Make sure we only scan each directory one time.
473 if {[info exists tclSeenPath
($dir)]} {
474 set use_path
[lrange $use_path 0 end-1
]
477 set tclSeenPath
($dir) 1
479 # we can't use glob in safe interps, so enclose the following
480 # in a catch statement, where we get the pkgIndex files out
481 # of the subdirectories
483 foreach file [glob -directory $dir -join -nocomplain \
485 set dir
[file dirname
$file]
486 if {![info exists procdDirs
($dir)]} {
487 set code
[catch {source $file} msg opt
]
489 [lindex [dict get
$opt -errorcode] 0] eq
"POSIX" &&
490 [lindex [dict get
$opt -errorcode] 1] eq
"EACCES"} {
491 # $file was not readable; silently ignore
495 tclLog
"error reading package index file $file: $msg"
497 set procdDirs
($dir) 1
502 set dir
[lindex $use_path end
]
503 if {![info exists procdDirs
($dir)]} {
504 set file [file join $dir pkgIndex.tcl
]
505 # safe interps usually don't have "file exists",
506 if {([interp issafe
] ||
[file exists
$file])} {
507 set code
[catch {source $file} msg opt
]
509 [lindex [dict get
$opt -errorcode] 0] eq
"POSIX" &&
510 [lindex [dict get
$opt -errorcode] 1] eq
"EACCES"} {
511 # $file was not readable; silently ignore
515 tclLog
"error reading package index file $file: $msg"
517 set procdDirs
($dir) 1
522 set use_path
[lrange $use_path 0 end-1
]
524 # Check whether any of the index scripts we [source]d above
525 # set a new value for $::auto_path. If so, then find any
526 # new directories on the $::auto_path, and lappend them to
527 # the $use_path we are working from. This gives index scripts
528 # the (arguably unwise) power to expand the index script search
529 # path while the search is in progress.
531 if {[llength $old_path] == [llength $auto_path]} {
532 foreach dir
$auto_path old
$old_path {
534 # This entry in $::auto_path has changed.
541 # $index now points to the first element of $auto_path that
542 # has changed, or the beginning if $auto_path has changed length
543 # Scan the new elements of $auto_path for directories to add to
544 # $use_path. Don't add directories we've already seen, or ones
545 # already on the $use_path.
546 foreach dir
[lrange $auto_path $index end
] {
547 if {![info exists tclSeenPath
($dir)]
548 && ([lsearch -exact $use_path $dir] == -1) } {
549 lappend use_path
$dir
552 set old_path
$auto_path
556 # tcl::MacOSXPkgUnknown --
557 # This procedure extends the "package unknown" function for MacOSX.
558 # It scans the Resources/Scripts directories of the immediate children
559 # of the auto_path directories for pkgIndex files.
562 # original - original [package unknown] procedure
563 # name - Name of desired package. Not used.
564 # version - Version of desired package. Not used.
565 # exact - Either "-exact" or omitted. Not used.
567 proc tcl
::MacOSXPkgUnknown {original name args
} {
569 # First do the cross-platform default search
570 uplevel 1 $original [linsert $args 0 $name]
572 # Now do MacOSX specific searching
575 if {![info exists auto_path
]} {
578 # Cache the auto_path, because it may change while we run through
579 # the first set of pkgIndex.tcl files
580 set old_path
[set use_path
$auto_path]
581 while {[llength $use_path]} {
582 set dir
[lindex $use_path end
]
584 # Make sure we only scan each directory one time.
585 if {[info exists tclSeenPath
($dir)]} {
586 set use_path
[lrange $use_path 0 end-1
]
589 set tclSeenPath
($dir) 1
591 # get the pkgIndex files out of the subdirectories
592 foreach file [glob -directory $dir -join -nocomplain \
593 * Resources Scripts pkgIndex.tcl
] {
594 set dir
[file dirname
$file]
595 if {![info exists procdDirs
($dir)]} {
596 set code
[catch {source $file} msg opt
]
598 [lindex [dict get
$opt -errorcode] 0] eq
"POSIX" &&
599 [lindex [dict get
$opt -errorcode] 1] eq
"EACCES"} {
600 # $file was not readable; silently ignore
604 tclLog
"error reading package index file $file: $msg"
606 set procdDirs
($dir) 1
610 set use_path
[lrange $use_path 0 end-1
]
612 # Check whether any of the index scripts we [source]d above
613 # set a new value for $::auto_path. If so, then find any
614 # new directories on the $::auto_path, and lappend them to
615 # the $use_path we are working from. This gives index scripts
616 # the (arguably unwise) power to expand the index script search
617 # path while the search is in progress.
619 if {[llength $old_path] == [llength $auto_path]} {
620 foreach dir
$auto_path old
$old_path {
622 # This entry in $::auto_path has changed.
629 # $index now points to the first element of $auto_path that
630 # has changed, or the beginning if $auto_path has changed length
631 # Scan the new elements of $auto_path for directories to add to
632 # $use_path. Don't add directories we've already seen, or ones
633 # already on the $use_path.
634 foreach dir
[lrange $auto_path $index end
] {
635 if {![info exists tclSeenPath
($dir)]
636 && ([lsearch -exact $use_path $dir] == -1) } {
637 lappend use_path
$dir
640 set old_path
$auto_path
644 # ::tcl::Pkg::Create --
646 # Given a package specification generate a "package ifneeded" statement
647 # for the package, suitable for inclusion in a pkgIndex.tcl file.
650 # args arguments used by the Create function:
652 # -version packageVersion
653 # -load {filename ?{procs}?}
655 # -source {filename ?{procs}?}
658 # Any number of -load and -source parameters may be
659 # specified, so long as there is at least one -load or
660 # -source parameter. If the procs component of a
661 # module specifier is left off, that module will be
662 # set up for direct loading; otherwise, it will be
663 # set up for lazy loading. If both -source and -load
664 # are specified, the -load'ed files will be loaded
665 # first, followed by the -source'd files.
668 # An appropriate "package ifneeded" statement for the package.
670 proc ::tcl::Pkg::Create {args
} {
671 append err
(usage
) "[lindex [info level 0] 0] "
672 append err
(usage
) "-name packageName -version packageVersion"
673 append err
(usage
) "?-load {filename ?{procs}?}? ... "
674 append err
(usage
) "?-source {filename ?{procs}?}? ..."
676 set err
(wrongNumArgs
) "wrong # args: should be \"$err(usage)\""
677 set err
(valueMissing
) "value for \"%s\" missing: should be \"$err(usage)\""
678 set err
(unknownOpt
) "unknown option \"%s\": should be \"$err(usage)\""
679 set err
(noLoadOrSource
) "at least one of -load and -source must be given"
682 set len
[llength $args]
684 error $err(wrongNumArgs
)
687 # Initialize parameters
689 set opts
(-version) {}
694 for {set i
0} {$i < $len} {incr i
} {
695 set flag
[lindex $args $i]
697 switch -glob -- $flag {
701 error [format $err(valueMissing
) $flag]
703 set opts
($flag) [lindex $args $i]
708 error [format $err(valueMissing
) $flag]
710 lappend opts
($flag) [lindex $args $i]
713 error [format $err(unknownOpt
) [lindex $args $i]]
718 # Validate the parameters
719 if { [llength $opts(-name)] == 0 } {
720 error [format $err(valueMissing
) "-name"]
722 if { [llength $opts(-version)] == 0 } {
723 error [format $err(valueMissing
) "-version"]
726 if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {
727 error $err(noLoadOrSource
)
730 # OK, now everything is good. Generate the package ifneeded statment.
731 set cmdline
"package ifneeded $opts(-name) $opts(-version) "
736 # Handle -load and -source specs
737 foreach key
{load source} {
738 foreach filespec
$opts(-$key) {
739 foreach {filename proclist
} {{} {}} {
742 foreach {filename proclist
} $filespec {
746 if { [llength $proclist] == 0 } {
747 set cmd
"\[list $key \[file join \$dir [list $filename]\]\]"
750 lappend lazyFileList
[list $filename $key $proclist]
755 if { [llength $lazyFileList] > 0 } {
756 lappend cmdList
"\[list tclPkgSetup \$dir $opts(-name)\
757 $opts(-version) [list $lazyFileList]\]"
759 append cmdline
[join $cmdList "\\n"]
763 interp alias
{} ::pkg::create {} ::tcl::Pkg::Create