3 # utility procs formerly in init.tcl which can be loaded on demand
4 # for package management.
6 # RCS: @(#) $Id: package.tcl,v 1.23.2.4 2006/09/22 01:26:24 andreas_kupries Exp $
8 # Copyright (c) 1991-1993 The Regents of the University of California.
9 # Copyright (c) 1994-1998 Sun Microsystems, Inc.
11 # See the file "license.terms" for information on usage and redistribution
12 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15 # Create the package namespace
16 namespace eval ::pkg {
19 # pkg_compareExtension --
21 # Used internally by pkg_mkIndex to compare the extension of a file to
22 # a given extension. On Windows, it uses a case-insensitive comparison
23 # because the file system can be file insensitive.
26 # fileName name of a file whose extension is compared
27 # ext (optional) The extension to compare against; you must
28 # provide the starting dot.
29 # Defaults to [info sharedlibextension]
32 # Returns 1 if the extension matches, 0 otherwise
34 proc pkg_compareExtension
{ fileName
{ext
{}} } {
36 if {$ext eq
""} {set ext
[info sharedlibextension
]}
37 if {$tcl_platform(platform
) eq
"windows"} {
38 return [string equal
-nocase [file extension
$fileName] $ext]
40 # Some unices add trailing numbers after the .so, so
41 # we could have something like '.so.1.2'.
44 set currExt
[file extension
$root]
45 if {$currExt eq
$ext} {
49 # The current extension does not match; if it is not a numeric
50 # value, quit, as we are only looking to ignore version number
51 # extensions. Otherwise we might return 1 in this case:
52 # pkg_compareExtension foo.so.bar .so
53 # which should not match.
55 if { ![string is integer
-strict [string range
$currExt 1 end
]] } {
58 set root
[file rootname
$root]
64 # This procedure creates a package index in a given directory. The
65 # package index consists of a "pkgIndex.tcl" file whose contents are
66 # a Tcl script that sets up package information with "package require"
67 # commands. The commands describe all of the packages defined by the
68 # files given as arguments.
71 # -direct (optional) If this flag is present, the generated
72 # code in pkgMkIndex.tcl will cause the package to be
73 # loaded when "package require" is executed, rather
74 # than lazily when the first reference to an exported
75 # procedure in the package is made.
76 # -verbose (optional) Verbose output; the name of each file that
77 # was successfully rocessed is printed out. Additionally,
78 # if processing of a file failed a message is printed.
79 # -load pat (optional) Preload any packages whose names match
80 # the pattern. Used to handle DLLs that depend on
81 # other packages during their Init procedure.
82 # dir - Name of the directory in which to create the index.
83 # args - Any number of additional arguments, each giving
84 # a glob pattern that matches the names of one or
85 # more shared libraries or Tcl script files in
88 proc pkg_mkIndex {args
} {
89 global errorCode errorInfo
90 set usage
{"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"};
92 set argCount
[llength $args]
94 return -code error "wrong # args: should be\n$usage"
101 for {set idx
0} {$idx < $argCount} {incr idx
} {
102 set flag
[lindex $args $idx]
103 switch -glob -- $flag {
105 # done with the flags
117 append more
" -direct"
121 set loadPat
[lindex $args $idx]
122 append more
" -load $loadPat"
125 return -code error "unknown flag $flag: should be\n$usage"
128 # done with the flags
134 set dir
[lindex $args $idx]
135 set patternList
[lrange $args [expr {$idx + 1}] end
]
136 if {[llength $patternList] == 0} {
137 set patternList
[list "*.tcl" "*[info sharedlibextension]"]
143 if {[catch {eval [linsert $patternList 0 glob --]} fileList
]} {
144 global errorCode errorInfo
146 return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList
148 foreach file $fileList {
149 # For each file, figure out what commands and packages it provides.
150 # To do this, create a child interpreter, load the file into the
151 # interpreter, and get a list of the new commands and packages
154 if {$file eq
"pkgIndex.tcl"} {
158 # Changed back to the original directory before initializing the
159 # slave in case TCL_LIBRARY is a relative path (e.g. in the test
163 set c
[interp create
]
165 # Load into the child any packages currently loaded in the parent
166 # interpreter that match the -load pattern.
168 if {$loadPat ne
""} {
170 tclLog
"currently loaded packages: '[info loaded]'"
171 tclLog
"trying to load all packages matching $loadPat"
173 if {![llength [info loaded
]]} {
174 tclLog
"warning: no packages are currently loaded, nothing"
175 tclLog
"can possibly match '$loadPat'"
178 foreach pkg
[info loaded
] {
179 if {! [string match
-nocase $loadPat [lindex $pkg 1]]} {
183 tclLog
"package [lindex $pkg 1] matches '$loadPat'"
186 load [lindex $pkg 0] [lindex $pkg 1] $c
189 tclLog
"warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
191 } elseif
{$doVerbose} {
192 tclLog
"loaded [lindex $pkg 0] [lindex $pkg 1]"
194 if {[lindex $pkg 1] eq
"Tk"} {
195 # Withdraw . if Tk was loaded, to avoid showing a window.
196 $c eval [list wm withdraw .
]
202 # Stub out the package command so packages can
203 # require other packages.
205 rename package __package_orig
206 proc package {what args
} {
208 require
{ return ; # ignore transitive requires }
209 default { uplevel 1 [linsert $args 0 __package_orig
$what] }
212 proc tclPkgUnknown args
{}
213 package unknown tclPkgUnknown
215 # Stub out the unknown command so package can call
216 # into each other during their initialilzation.
218 proc unknown {args
} {}
220 # Stub out the auto_import mechanism
222 proc auto_import {args
} {}
224 # reserve the ::tcl namespace for support procs
225 # and temporary variables. This might make it awkward
226 # to generate a pkgIndex.tcl file for the ::tcl namespace.
228 namespace eval ::tcl {
229 variable file ;# Current file being processed
230 variable direct
;# -direct flag value
231 variable x
;# Loop variable
232 variable debug
;# For debugging
233 variable type
;# "load" or "source", for -direct
234 variable namespaces
;# Existing namespaces (e.g., ::tcl)
235 variable packages
;# Existing packages (e.g., Tcl)
236 variable origCmds
;# Existing commands
237 variable newCmds
;# Newly created commands
238 variable newPkgs
{} ;# Newly created packages
242 $c eval [list set ::tcl::file $file]
243 $c eval [list set ::tcl::direct $direct]
245 # Download needed procedures into the slave because we've
246 # just deleted the unknown procedure. This doesn't handle
247 # procedures with default arguments.
249 foreach p
{pkg_compareExtension
} {
250 $c eval [list proc $p [info args
$p] [info body
$p]]
255 set ::tcl::debug "loading or sourcing"
257 # we need to track command defined by each package even in
258 # the -direct case, because they are needed internally by
259 # the "partial pkgIndex.tcl" step above.
261 proc ::tcl::GetAllNamespaces {{root
::}} {
263 foreach ns
[namespace children
$root] {
264 eval [linsert [::tcl::GetAllNamespaces $ns] 0 \
270 # init the list of existing namespaces, packages, commands
272 foreach ::tcl::x [::tcl::GetAllNamespaces] {
273 set ::tcl::namespaces($::tcl::x) 1
275 foreach ::tcl::x [package names
] {
276 if {[package provide
$::tcl::x] ne
""} {
277 set ::tcl::packages($::tcl::x) 1
280 set ::tcl::origCmds [info commands
]
282 # Try to load the file if it has the shared library
283 # extension, otherwise source it. It's important not to
284 # try to load files that aren't shared libraries, because
285 # on some systems (like SunOS) the loader will abort the
286 # whole application when it gets an error.
288 if {[pkg_compareExtension
$::tcl::file [info sharedlibextension
]]} {
289 # The "file join ." command below is necessary.
290 # Without it, if the file name has no \'s and we're
291 # on UNIX, the load command will invoke the
292 # LD_LIBRARY_PATH search mechanism, which could cause
293 # the wrong file to be used.
295 set ::tcl::debug loading
296 load [file join .
$::tcl::file]
299 set ::tcl::debug sourcing
301 set ::tcl::type source
304 # As a performance optimization, if we are creating
305 # direct load packages, don't bother figuring out the
306 # set of commands created by the new packages. We
307 # only need that list for setting up the autoloading
308 # used in the non-direct case.
309 if { !$::tcl::direct } {
310 # See what new namespaces appeared, and import commands
311 # from them. Only exported commands go into the index.
313 foreach ::tcl::x [::tcl::GetAllNamespaces] {
314 if {! [info exists
::tcl::namespaces($::tcl::x)]} {
315 namespace import
-force ${::tcl::x}::*
318 # Figure out what commands appeared
320 foreach ::tcl::x [info commands
] {
321 set ::tcl::newCmds($::tcl::x) 1
323 foreach ::tcl::x $::tcl::origCmds {
324 unset -nocomplain ::tcl::newCmds($::tcl::x)
326 foreach ::tcl::x [array names
::tcl::newCmds] {
327 # determine which namespace a command comes from
329 set ::tcl::abs [namespace origin
$::tcl::x]
331 # special case so that global names have no leading
332 # ::, this is required by the unknown command
335 [lindex [auto_qualify $::tcl::abs ::] 0]
337 if {$::tcl::x ne
$::tcl::abs} {
338 # Name changed during qualification
340 set ::tcl::newCmds($::tcl::abs) 1
341 unset ::tcl::newCmds($::tcl::x)
347 # Look through the packages that appeared, and if there is
348 # a version provided, then record it
350 foreach ::tcl::x [package names
] {
351 if {[package provide
$::tcl::x] ne
""
352 && ![info exists
::tcl::packages($::tcl::x)]} {
353 lappend ::tcl::newPkgs \
354 [list $::tcl::x [package provide
$::tcl::x]]
359 set what
[$c eval set ::tcl::debug]
361 tclLog
"warning: error while $what $file: $msg"
364 set what
[$c eval set ::tcl::debug]
366 tclLog
"successful $what of $file"
368 set type
[$c eval set ::tcl::type]
369 set cmds
[lsort [$c eval array names
::tcl::newCmds]]
370 set pkgs
[$c eval set ::tcl::newPkgs]
373 tclLog
"commands provided were $cmds"
375 tclLog
"packages provided were $pkgs"
377 if {[llength $pkgs] > 1} {
378 tclLog
"warning: \"$file\" provides more than one package ($pkgs)"
381 # cmds is empty/not used in the direct case
382 lappend files
($pkg) [list $file $type $cmds]
386 tclLog
"processed $file"
392 append index
"# Tcl package index file, version 1.1\n"
393 append index
"# This file is generated by the \"pkg_mkIndex$more\" command\n"
394 append index
"# and sourced either when an application starts up or\n"
395 append index
"# by a \"package unknown\" script. It invokes the\n"
396 append index
"# \"package ifneeded\" command to set up package-related\n"
397 append index
"# information so that packages will be loaded automatically\n"
398 append index
"# in response to \"package require\" commands. When this\n"
399 append index
"# script is sourced, the variable \$dir must contain the\n"
400 append index
"# full path name of this file's directory.\n"
402 foreach pkg
[lsort [array names files
]] {
404 foreach {name version
} $pkg {
407 lappend cmd
::pkg::create -name $name -version $version
408 foreach spec
$files($pkg) {
409 foreach {file type procs
} $spec {
413 lappend cmd
"-$type" [list $file $procs]
416 append index
"\n[eval $cmd]"
419 set f
[open pkgIndex.tcl w
]
426 # This is a utility procedure use by pkgIndex.tcl files. It is invoked
427 # as part of a "package ifneeded" script. It calls "package provide"
428 # to indicate that a package is available, then sets entries in the
429 # auto_index array so that the package's files will be auto-loaded when
430 # the commands are used.
433 # dir - Directory containing all the files for this package.
434 # pkg - Name of the package (no version number).
435 # version - Version number for the package, such as 2.1.3.
436 # files - List of files that constitute the package. Each
437 # element is a sub-list with three elements. The first
438 # is the name of a file relative to $dir, the second is
439 # "load" or "source", indicating whether the file is a
440 # loadable binary or a script to source, and the third
441 # is a list of commands defined by this file.
443 proc tclPkgSetup
{dir pkg version files
} {
446 package provide
$pkg $version
447 foreach fileInfo
$files {
448 set f
[lindex $fileInfo 0]
449 set type
[lindex $fileInfo 1]
450 foreach cmd
[lindex $fileInfo 2] {
451 if {$type eq
"load"} {
452 set auto_index
($cmd) [list load [file join $dir $f] $pkg]
454 set auto_index
($cmd) [list source [file join $dir $f]]
461 # This procedure provides the default for the "package unknown" function.
462 # It is invoked when a package that's needed can't be found. It scans
463 # the auto_path directories and their immediate children looking for
464 # pkgIndex.tcl files and sources any such files that are found to setup
465 # the package database. (On the Macintosh we also search for pkgIndex
466 # TEXT resources in all files.) As it searches, it will recognize changes
467 # to the auto_path and scan any new directories.
470 # name - Name of desired package. Not used.
471 # version - Version of desired package. Not used.
472 # exact - Either "-exact" or omitted. Not used.
475 proc tclPkgUnknown
[expr {
476 [info exists tcl_platform
(tip
,268)]
478 : "name version {exact {}}"
482 if {![info exists auto_path
]} {
485 # Cache the auto_path, because it may change while we run through
486 # the first set of pkgIndex.tcl files
487 set old_path
[set use_path
$auto_path]
488 while {[llength $use_path]} {
489 set dir
[lindex $use_path end
]
491 # Make sure we only scan each directory one time.
492 if {[info exists tclSeenPath
($dir)]} {
493 set use_path
[lrange $use_path 0 end-1
]
496 set tclSeenPath
($dir) 1
498 # we can't use glob in safe interps, so enclose the following
499 # in a catch statement, where we get the pkgIndex files out
500 # of the subdirectories
502 foreach file [glob -directory $dir -join -nocomplain \
504 set dir
[file dirname
$file]
505 if {![info exists procdDirs
($dir)] && [file readable
$file]} {
506 if {[catch {source $file} msg
]} {
507 tclLog
"error reading package index file $file: $msg"
509 set procdDirs
($dir) 1
514 set dir
[lindex $use_path end
]
515 if {![info exists procdDirs
($dir)]} {
516 set file [file join $dir pkgIndex.tcl
]
517 # safe interps usually don't have "file readable",
519 if {([interp issafe
] ||
[file readable
$file])} {
520 if {[catch {source $file} msg
] && ![interp issafe
]} {
521 tclLog
"error reading package index file $file: $msg"
523 set procdDirs
($dir) 1
528 set use_path
[lrange $use_path 0 end-1
]
530 # Check whether any of the index scripts we [source]d above
531 # set a new value for $::auto_path. If so, then find any
532 # new directories on the $::auto_path, and lappend them to
533 # the $use_path we are working from. This gives index scripts
534 # the (arguably unwise) power to expand the index script search
535 # path while the search is in progress.
537 if {[llength $old_path] == [llength $auto_path]} {
538 foreach dir
$auto_path old
$old_path {
540 # This entry in $::auto_path has changed.
547 # $index now points to the first element of $auto_path that
548 # has changed, or the beginning if $auto_path has changed length
549 # Scan the new elements of $auto_path for directories to add to
550 # $use_path. Don't add directories we've already seen, or ones
551 # already on the $use_path.
552 foreach dir
[lrange $auto_path $index end
] {
553 if {![info exists tclSeenPath
($dir)]
554 && ([lsearch -exact $use_path $dir] == -1) } {
555 lappend use_path
$dir
558 set old_path
$auto_path
562 # tcl::MacOSXPkgUnknown --
563 # This procedure extends the "package unknown" function for MacOSX.
564 # It scans the Resources/Scripts directories of the immediate children
565 # of the auto_path directories for pkgIndex files.
566 # Only installed in interps that are not safe so we don't check
567 # for [interp issafe] as in tclPkgUnknown.
570 # original - original [package unknown] procedure
571 # name - Name of desired package. Not used.
573 # version - Version of desired package. Not used.
574 # exact - Either "-exact" or omitted. Not used.
576 # args - List of requirements. Not used.
579 if {[info exists tcl_platform
(tip
,268)]} {
580 proc tcl
::MacOSXPkgUnknown {original name args
} {
581 # First do the cross-platform default search
582 uplevel 1 $original [linsert $args 0 $name]
584 # Now do MacOSX specific searching
587 if {![info exists auto_path
]} {
590 # Cache the auto_path, because it may change while we run through
591 # the first set of pkgIndex.tcl files
592 set old_path
[set use_path
$auto_path]
593 while {[llength $use_path]} {
594 set dir
[lindex $use_path end
]
595 # get the pkgIndex files out of the subdirectories
596 foreach file [glob -directory $dir -join -nocomplain \
597 * Resources Scripts pkgIndex.tcl
] {
598 set dir
[file dirname
$file]
599 if {[file readable
$file] && ![info exists procdDirs
($dir)]} {
600 if {[catch {source $file} msg
]} {
601 tclLog
"error reading package index file $file: $msg"
603 set procdDirs
($dir) 1
607 set use_path
[lrange $use_path 0 end-1
]
608 if {$old_path ne
$auto_path} {
609 foreach dir
$auto_path {
610 lappend use_path
$dir
612 set old_path
$auto_path
617 proc tcl
::MacOSXPkgUnknown {original name version
{exact
{}}} {
619 # First do the cross-platform default search
620 uplevel 1 $original [list $name $version $exact]
622 # Now do MacOSX specific searching
625 if {![info exists auto_path
]} {
628 # Cache the auto_path, because it may change while we run through
629 # the first set of pkgIndex.tcl files
630 set old_path
[set use_path
$auto_path]
631 while {[llength $use_path]} {
632 set dir
[lindex $use_path end
]
633 # get the pkgIndex files out of the subdirectories
634 foreach file [glob -directory $dir -join -nocomplain \
635 * Resources Scripts pkgIndex.tcl
] {
636 set dir
[file dirname
$file]
637 if {[file readable
$file] && ![info exists procdDirs
($dir)]} {
638 if {[catch {source $file} msg
]} {
639 tclLog
"error reading package index file $file: $msg"
641 set procdDirs
($dir) 1
645 set use_path
[lrange $use_path 0 end-1
]
646 if {$old_path ne
$auto_path} {
647 foreach dir
$auto_path {
648 lappend use_path
$dir
650 set old_path
$auto_path
656 # tcl::MacPkgUnknown --
657 # This procedure extends the "package unknown" function for Mac.
658 # It searches for pkgIndex TEXT resources in all files
659 # Only installed in interps that are not safe so we don't check
660 # for [interp issafe] as in tclPkgUnknown.
663 # original - original [package unknown] procedure
664 # name - Name of desired package. Not used.
665 # version - Version of desired package. Not used.
666 # exact - Either "-exact" or omitted. Not used.
668 proc tcl
::MacPkgUnknown {original name version
{exact
{}}} {
670 # First do the cross-platform default search
671 uplevel 1 $original [list $name $version $exact]
673 # Now do Mac specific searching
676 if {![info exists auto_path
]} {
679 # Cache the auto_path, because it may change while we run through
680 # the first set of pkgIndex.tcl files
681 set old_path
[set use_path
$auto_path]
682 while {[llength $use_path]} {
683 # We look for pkgIndex TEXT resources in the resource fork of shared libraries
684 set dir
[lindex $use_path end
]
685 foreach x
[concat [list $dir] [glob -directory $dir -nocomplain *] ] {
686 if {[file isdirectory
$x] && ![info exists procdDirs
($x)]} {
688 foreach x
[glob -directory $dir -nocomplain *.shlb
] {
689 if {[file isfile
$x]} {
690 set res
[resource open $x]
691 foreach y
[resource list TEXT
$res] {
692 if {$y eq
"pkgIndex"} {source -rsrc pkgIndex
}
694 catch {resource close $res}
697 set procdDirs
($dir) 1
700 set use_path
[lrange $use_path 0 end-1
]
701 if {$old_path ne
$auto_path} {
702 foreach dir
$auto_path {
703 lappend use_path
$dir
705 set old_path
$auto_path
712 # Given a package specification generate a "package ifneeded" statement
713 # for the package, suitable for inclusion in a pkgIndex.tcl file.
716 # args arguments used by the create function:
718 # -version packageVersion
719 # -load {filename ?{procs}?}
721 # -source {filename ?{procs}?}
724 # Any number of -load and -source parameters may be
725 # specified, so long as there is at least one -load or
726 # -source parameter. If the procs component of a
727 # module specifier is left off, that module will be
728 # set up for direct loading; otherwise, it will be
729 # set up for lazy loading. If both -source and -load
730 # are specified, the -load'ed files will be loaded
731 # first, followed by the -source'd files.
734 # An appropriate "package ifneeded" statement for the package.
736 proc ::pkg::create {args
} {
737 append err
(usage
) "[lindex [info level 0] 0] "
738 append err
(usage
) "-name packageName -version packageVersion"
739 append err
(usage
) "?-load {filename ?{procs}?}? ... "
740 append err
(usage
) "?-source {filename ?{procs}?}? ..."
742 set err
(wrongNumArgs
) "wrong # args: should be \"$err(usage)\""
743 set err
(valueMissing
) "value for \"%s\" missing: should be \"$err(usage)\""
744 set err
(unknownOpt
) "unknown option \"%s\": should be \"$err(usage)\""
745 set err
(noLoadOrSource
) "at least one of -load and -source must be given"
748 set len
[llength $args]
750 error $err(wrongNumArgs
)
753 # Initialize parameters
755 set opts
(-version) {}
760 for {set i
0} {$i < $len} {incr i
} {
761 set flag
[lindex $args $i]
763 switch -glob -- $flag {
767 error [format $err(valueMissing
) $flag]
769 set opts
($flag) [lindex $args $i]
774 error [format $err(valueMissing
) $flag]
776 lappend opts
($flag) [lindex $args $i]
779 error [format $err(unknownOpt
) [lindex $args $i]]
784 # Validate the parameters
785 if { [llength $opts(-name)] == 0 } {
786 error [format $err(valueMissing
) "-name"]
788 if { [llength $opts(-version)] == 0 } {
789 error [format $err(valueMissing
) "-version"]
792 if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {
793 error $err(noLoadOrSource
)
796 # OK, now everything is good. Generate the package ifneeded statment.
797 set cmdline
"package ifneeded $opts(-name) $opts(-version) "
802 # Handle -load and -source specs
803 foreach key
{load source} {
804 foreach filespec
$opts(-$key) {
805 foreach {filename proclist
} {{} {}} {
808 foreach {filename proclist
} $filespec {
812 if { [llength $proclist] == 0 } {
813 set cmd
"\[list $key \[file join \$dir [list $filename]\]\]"
816 lappend lazyFileList
[list $filename $key $proclist]
821 if { [llength $lazyFileList] > 0 } {
822 lappend cmdList
"\[list tclPkgSetup \$dir $opts(-name)\
823 $opts(-version) [list $lazyFileList]\]"
825 append cmdline
[join $cmdList "\\n"]