3 # utility procs formerly in init.tcl which can be loaded on demand
4 # for package management.
6 # RCS: @(#) $Id: package.tcl,v 1.35.4.1 2008/07/03 17:22:59 dgp 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 namespace eval tcl
::Pkg {}
17 # ::tcl::Pkg::CompareExtension --
19 # Used internally by pkg_mkIndex to compare the extension of a file to
20 # a given extension. On Windows, it uses a case-insensitive comparison
21 # because the file system can be file insensitive.
24 # fileName name of a file whose extension is compared
25 # ext (optional) The extension to compare against; you must
26 # provide the starting dot.
27 # Defaults to [info sharedlibextension]
30 # Returns 1 if the extension matches, 0 otherwise
32 proc tcl
::Pkg::CompareExtension { fileName
{ext
{}} } {
34 if {$ext eq
""} {set ext
[info sharedlibextension
]}
35 if {$tcl_platform(platform
) eq
"windows"} {
36 return [string equal
-nocase [file extension
$fileName] $ext]
38 # Some unices add trailing numbers after the .so, so
39 # we could have something like '.so.1.2'.
42 set currExt
[file extension
$root]
43 if {$currExt eq
$ext} {
47 # The current extension does not match; if it is not a numeric
48 # value, quit, as we are only looking to ignore version number
49 # extensions. Otherwise we might return 1 in this case:
50 # tcl::Pkg::CompareExtension foo.so.bar .so
51 # which should not match.
53 if { ![string is integer
-strict [string range
$currExt 1 end
]] } {
56 set root
[file rootname
$root]
62 # This procedure creates a package index in a given directory. The
63 # package index consists of a "pkgIndex.tcl" file whose contents are
64 # a Tcl script that sets up package information with "package require"
65 # commands. The commands describe all of the packages defined by the
66 # files given as arguments.
69 # -direct (optional) If this flag is present, the generated
70 # code in pkgMkIndex.tcl will cause the package to be
71 # loaded when "package require" is executed, rather
72 # than lazily when the first reference to an exported
73 # procedure in the package is made.
74 # -verbose (optional) Verbose output; the name of each file that
75 # was successfully rocessed is printed out. Additionally,
76 # if processing of a file failed a message is printed.
77 # -load pat (optional) Preload any packages whose names match
78 # the pattern. Used to handle DLLs that depend on
79 # other packages during their Init procedure.
80 # dir - Name of the directory in which to create the index.
81 # args - Any number of additional arguments, each giving
82 # a glob pattern that matches the names of one or
83 # more shared libraries or Tcl script files in
86 proc pkg_mkIndex {args
} {
87 set usage
{"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"};
89 set argCount
[llength $args]
91 return -code error "wrong # args: should be\n$usage"
98 for {set idx
0} {$idx < $argCount} {incr idx
} {
99 set flag
[lindex $args $idx]
100 switch -glob -- $flag {
102 # done with the flags
114 append more
" -direct"
118 set loadPat
[lindex $args $idx]
119 append more
" -load $loadPat"
122 return -code error "unknown flag $flag: should be\n$usage"
125 # done with the flags
131 set dir
[lindex $args $idx]
132 set patternList
[lrange $args [expr {$idx + 1}] end
]
133 if {[llength $patternList] == 0} {
134 set patternList
[list "*.tcl" "*[info sharedlibextension]"]
138 glob -directory $dir -tails -types {r f
} -- {*}$patternList
140 return -options $o $fileList
142 foreach file $fileList {
143 # For each file, figure out what commands and packages it provides.
144 # To do this, create a child interpreter, load the file into the
145 # interpreter, and get a list of the new commands and packages
148 if {$file eq
"pkgIndex.tcl"} {
152 set c
[interp create
]
154 # Load into the child any packages currently loaded in the parent
155 # interpreter that match the -load pattern.
157 if {$loadPat ne
""} {
159 tclLog
"currently loaded packages: '[info loaded]'"
160 tclLog
"trying to load all packages matching $loadPat"
162 if {![llength [info loaded
]]} {
163 tclLog
"warning: no packages are currently loaded, nothing"
164 tclLog
"can possibly match '$loadPat'"
167 foreach pkg
[info loaded
] {
168 if {! [string match
-nocase $loadPat [lindex $pkg 1]]} {
172 tclLog
"package [lindex $pkg 1] matches '$loadPat'"
175 load [lindex $pkg 0] [lindex $pkg 1] $c
178 tclLog
"warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
180 } elseif
{$doVerbose} {
181 tclLog
"loaded [lindex $pkg 0] [lindex $pkg 1]"
183 if {[lindex $pkg 1] eq
"Tk"} {
184 # Withdraw . if Tk was loaded, to avoid showing a window.
185 $c eval [list wm withdraw .
]
190 # Stub out the package command so packages can
191 # require other packages.
193 rename package __package_orig
194 proc package {what args
} {
196 require
{ return ; # ignore transitive requires }
197 default { __package_orig
$what {*}$args }
200 proc tclPkgUnknown args
{}
201 package unknown tclPkgUnknown
203 # Stub out the unknown command so package can call
204 # into each other during their initialilzation.
206 proc unknown {args
} {}
208 # Stub out the auto_import mechanism
210 proc auto_import {args
} {}
212 # reserve the ::tcl namespace for support procs
213 # and temporary variables. This might make it awkward
214 # to generate a pkgIndex.tcl file for the ::tcl namespace.
216 namespace eval ::tcl {
217 variable dir
;# Current directory being processed
218 variable file ;# Current file being processed
219 variable direct
;# -direct flag value
220 variable x
;# Loop variable
221 variable debug
;# For debugging
222 variable type
;# "load" or "source", for -direct
223 variable namespaces
;# Existing namespaces (e.g., ::tcl)
224 variable packages
;# Existing packages (e.g., Tcl)
225 variable origCmds
;# Existing commands
226 variable newCmds
;# Newly created commands
227 variable newPkgs
{} ;# Newly created packages
231 $c eval [list set ::tcl::dir $dir]
232 $c eval [list set ::tcl::file $file]
233 $c eval [list set ::tcl::direct $direct]
235 # Download needed procedures into the slave because we've
236 # just deleted the unknown procedure. This doesn't handle
237 # procedures with default arguments.
239 foreach p
{::tcl::Pkg::CompareExtension} {
240 $c eval [list namespace eval [namespace qualifiers
$p] {}]
241 $c eval [list proc $p [info args
$p] [info body
$p]]
246 set ::tcl::debug "loading or sourcing"
248 # we need to track command defined by each package even in
249 # the -direct case, because they are needed internally by
250 # the "partial pkgIndex.tcl" step above.
252 proc ::tcl::GetAllNamespaces {{root
::}} {
254 foreach ns
[namespace children
$root] {
255 lappend list {*}[::tcl::GetAllNamespaces $ns]
260 # init the list of existing namespaces, packages, commands
262 foreach ::tcl::x [::tcl::GetAllNamespaces] {
263 set ::tcl::namespaces($::tcl::x) 1
265 foreach ::tcl::x [package names
] {
266 if {[package provide
$::tcl::x] ne
""} {
267 set ::tcl::packages($::tcl::x) 1
270 set ::tcl::origCmds [info commands
]
272 # Try to load the file if it has the shared library
273 # extension, otherwise source it. It's important not to
274 # try to load files that aren't shared libraries, because
275 # on some systems (like SunOS) the loader will abort the
276 # whole application when it gets an error.
278 if {[::tcl::Pkg::CompareExtension $::tcl::file [info sharedlibextension
]]} {
279 # The "file join ." command below is necessary.
280 # Without it, if the file name has no \'s and we're
281 # on UNIX, the load command will invoke the
282 # LD_LIBRARY_PATH search mechanism, which could cause
283 # the wrong file to be used.
285 set ::tcl::debug loading
286 load [file join $::tcl::dir $::tcl::file]
289 set ::tcl::debug sourcing
290 source [file join $::tcl::dir $::tcl::file]
291 set ::tcl::type source
294 # As a performance optimization, if we are creating
295 # direct load packages, don't bother figuring out the
296 # set of commands created by the new packages. We
297 # only need that list for setting up the autoloading
298 # used in the non-direct case.
299 if { !$::tcl::direct } {
300 # See what new namespaces appeared, and import commands
301 # from them. Only exported commands go into the index.
303 foreach ::tcl::x [::tcl::GetAllNamespaces] {
304 if {! [info exists
::tcl::namespaces($::tcl::x)]} {
305 namespace import
-force ${::tcl::x}::*
308 # Figure out what commands appeared
310 foreach ::tcl::x [info commands
] {
311 set ::tcl::newCmds($::tcl::x) 1
313 foreach ::tcl::x $::tcl::origCmds {
314 unset -nocomplain ::tcl::newCmds($::tcl::x)
316 foreach ::tcl::x [array names
::tcl::newCmds] {
317 # determine which namespace a command comes from
319 set ::tcl::abs [namespace origin
$::tcl::x]
321 # special case so that global names have no leading
322 # ::, this is required by the unknown command
325 [lindex [auto_qualify $::tcl::abs ::] 0]
327 if {$::tcl::x ne
$::tcl::abs} {
328 # Name changed during qualification
330 set ::tcl::newCmds($::tcl::abs) 1
331 unset ::tcl::newCmds($::tcl::x)
337 # Look through the packages that appeared, and if there is
338 # a version provided, then record it
340 foreach ::tcl::x [package names
] {
341 if {[package provide
$::tcl::x] ne
""
342 && ![info exists
::tcl::packages($::tcl::x)]} {
343 lappend ::tcl::newPkgs \
344 [list $::tcl::x [package provide
$::tcl::x]]
349 set what
[$c eval set ::tcl::debug]
351 tclLog
"warning: error while $what $file: $msg"
354 set what
[$c eval set ::tcl::debug]
356 tclLog
"successful $what of $file"
358 set type
[$c eval set ::tcl::type]
359 set cmds
[lsort [$c eval array names
::tcl::newCmds]]
360 set pkgs
[$c eval set ::tcl::newPkgs]
363 tclLog
"commands provided were $cmds"
365 tclLog
"packages provided were $pkgs"
367 if {[llength $pkgs] > 1} {
368 tclLog
"warning: \"$file\" provides more than one package ($pkgs)"
371 # cmds is empty/not used in the direct case
372 lappend files
($pkg) [list $file $type $cmds]
376 tclLog
"processed $file"
382 append index
"# Tcl package index file, version 1.1\n"
383 append index
"# This file is generated by the \"pkg_mkIndex$more\" command\n"
384 append index
"# and sourced either when an application starts up or\n"
385 append index
"# by a \"package unknown\" script. It invokes the\n"
386 append index
"# \"package ifneeded\" command to set up package-related\n"
387 append index
"# information so that packages will be loaded automatically\n"
388 append index
"# in response to \"package require\" commands. When this\n"
389 append index
"# script is sourced, the variable \$dir must contain the\n"
390 append index
"# full path name of this file's directory.\n"
392 foreach pkg
[lsort [array names files
]] {
394 foreach {name version
} $pkg {
397 lappend cmd
::tcl::Pkg::Create -name $name -version $version
398 foreach spec
$files($pkg) {
399 foreach {file type procs
} $spec {
403 lappend cmd
"-$type" [list $file $procs]
406 append index
"\n[eval $cmd]"
409 set f
[open [file join $dir pkgIndex.tcl
] w
]
415 # This is a utility procedure use by pkgIndex.tcl files. It is invoked
416 # as part of a "package ifneeded" script. It calls "package provide"
417 # to indicate that a package is available, then sets entries in the
418 # auto_index array so that the package's files will be auto-loaded when
419 # the commands are used.
422 # dir - Directory containing all the files for this package.
423 # pkg - Name of the package (no version number).
424 # version - Version number for the package, such as 2.1.3.
425 # files - List of files that constitute the package. Each
426 # element is a sub-list with three elements. The first
427 # is the name of a file relative to $dir, the second is
428 # "load" or "source", indicating whether the file is a
429 # loadable binary or a script to source, and the third
430 # is a list of commands defined by this file.
432 proc tclPkgSetup
{dir pkg version files
} {
435 package provide
$pkg $version
436 foreach fileInfo
$files {
437 set f
[lindex $fileInfo 0]
438 set type
[lindex $fileInfo 1]
439 foreach cmd
[lindex $fileInfo 2] {
440 if {$type eq
"load"} {
441 set auto_index
($cmd) [list load [file join $dir $f] $pkg]
443 set auto_index
($cmd) [list source [file join $dir $f]]
450 # This procedure provides the default for the "package unknown" function.
451 # It is invoked when a package that's needed can't be found. It scans
452 # the auto_path directories and their immediate children looking for
453 # pkgIndex.tcl files and sources any such files that are found to setup
454 # the package database. As it searches, it will recognize changes
455 # to the auto_path and scan any new directories.
458 # name - Name of desired package. Not used.
459 # version - Version of desired package. Not used.
460 # exact - Either "-exact" or omitted. Not used.
462 proc tclPkgUnknown
{name args
} {
465 if {![info exists auto_path
]} {
468 # Cache the auto_path, because it may change while we run through
469 # the first set of pkgIndex.tcl files
470 set old_path
[set use_path
$auto_path]
471 while {[llength $use_path]} {
472 set dir
[lindex $use_path end
]
474 # Make sure we only scan each directory one time.
475 if {[info exists tclSeenPath
($dir)]} {
476 set use_path
[lrange $use_path 0 end-1
]
479 set tclSeenPath
($dir) 1
481 # we can't use glob in safe interps, so enclose the following
482 # in a catch statement, where we get the pkgIndex files out
483 # of the subdirectories
485 foreach file [glob -directory $dir -join -nocomplain \
487 set dir
[file dirname
$file]
488 if {![info exists procdDirs
($dir)]} {
489 set code
[catch {source $file} msg opt
]
491 [lindex [dict get
$opt -errorcode] 0] eq
"POSIX" &&
492 [lindex [dict get
$opt -errorcode] 1] eq
"EACCES"} {
493 # $file was not readable; silently ignore
497 tclLog
"error reading package index file $file: $msg"
499 set procdDirs
($dir) 1
504 set dir
[lindex $use_path end
]
505 if {![info exists procdDirs
($dir)]} {
506 set file [file join $dir pkgIndex.tcl
]
507 # safe interps usually don't have "file exists",
508 if {([interp issafe
] ||
[file exists
$file])} {
509 set code
[catch {source $file} msg opt
]
511 [lindex [dict get
$opt -errorcode] 0] eq
"POSIX" &&
512 [lindex [dict get
$opt -errorcode] 1] eq
"EACCES"} {
513 # $file was not readable; silently ignore
517 tclLog
"error reading package index file $file: $msg"
519 set procdDirs
($dir) 1
524 set use_path
[lrange $use_path 0 end-1
]
526 # Check whether any of the index scripts we [source]d above
527 # set a new value for $::auto_path. If so, then find any
528 # new directories on the $::auto_path, and lappend them to
529 # the $use_path we are working from. This gives index scripts
530 # the (arguably unwise) power to expand the index script search
531 # path while the search is in progress.
533 if {[llength $old_path] == [llength $auto_path]} {
534 foreach dir
$auto_path old
$old_path {
536 # This entry in $::auto_path has changed.
543 # $index now points to the first element of $auto_path that
544 # has changed, or the beginning if $auto_path has changed length
545 # Scan the new elements of $auto_path for directories to add to
546 # $use_path. Don't add directories we've already seen, or ones
547 # already on the $use_path.
548 foreach dir
[lrange $auto_path $index end
] {
549 if {![info exists tclSeenPath
($dir)]
550 && ([lsearch -exact $use_path $dir] == -1) } {
551 lappend use_path
$dir
554 set old_path
$auto_path
558 # tcl::MacOSXPkgUnknown --
559 # This procedure extends the "package unknown" function for MacOSX.
560 # It scans the Resources/Scripts directories of the immediate children
561 # of the auto_path directories for pkgIndex files.
564 # original - original [package unknown] procedure
565 # name - Name of desired package. Not used.
566 # version - Version of desired package. Not used.
567 # exact - Either "-exact" or omitted. Not used.
569 proc tcl
::MacOSXPkgUnknown {original name args
} {
571 # First do the cross-platform default search
572 uplevel 1 $original [linsert $args 0 $name]
574 # Now do MacOSX specific searching
577 if {![info exists auto_path
]} {
580 # Cache the auto_path, because it may change while we run through
581 # the first set of pkgIndex.tcl files
582 set old_path
[set use_path
$auto_path]
583 while {[llength $use_path]} {
584 set dir
[lindex $use_path end
]
586 # Make sure we only scan each directory one time.
587 if {[info exists tclSeenPath
($dir)]} {
588 set use_path
[lrange $use_path 0 end-1
]
591 set tclSeenPath
($dir) 1
593 # get the pkgIndex files out of the subdirectories
594 foreach file [glob -directory $dir -join -nocomplain \
595 * Resources Scripts pkgIndex.tcl
] {
596 set dir
[file dirname
$file]
597 if {![info exists procdDirs
($dir)]} {
598 set code
[catch {source $file} msg opt
]
600 [lindex [dict get
$opt -errorcode] 0] eq
"POSIX" &&
601 [lindex [dict get
$opt -errorcode] 1] eq
"EACCES"} {
602 # $file was not readable; silently ignore
606 tclLog
"error reading package index file $file: $msg"
608 set procdDirs
($dir) 1
612 set use_path
[lrange $use_path 0 end-1
]
614 # Check whether any of the index scripts we [source]d above
615 # set a new value for $::auto_path. If so, then find any
616 # new directories on the $::auto_path, and lappend them to
617 # the $use_path we are working from. This gives index scripts
618 # the (arguably unwise) power to expand the index script search
619 # path while the search is in progress.
621 if {[llength $old_path] == [llength $auto_path]} {
622 foreach dir
$auto_path old
$old_path {
624 # This entry in $::auto_path has changed.
631 # $index now points to the first element of $auto_path that
632 # has changed, or the beginning if $auto_path has changed length
633 # Scan the new elements of $auto_path for directories to add to
634 # $use_path. Don't add directories we've already seen, or ones
635 # already on the $use_path.
636 foreach dir
[lrange $auto_path $index end
] {
637 if {![info exists tclSeenPath
($dir)]
638 && ([lsearch -exact $use_path $dir] == -1) } {
639 lappend use_path
$dir
642 set old_path
$auto_path
646 # ::tcl::Pkg::Create --
648 # Given a package specification generate a "package ifneeded" statement
649 # for the package, suitable for inclusion in a pkgIndex.tcl file.
652 # args arguments used by the Create function:
654 # -version packageVersion
655 # -load {filename ?{procs}?}
657 # -source {filename ?{procs}?}
660 # Any number of -load and -source parameters may be
661 # specified, so long as there is at least one -load or
662 # -source parameter. If the procs component of a
663 # module specifier is left off, that module will be
664 # set up for direct loading; otherwise, it will be
665 # set up for lazy loading. If both -source and -load
666 # are specified, the -load'ed files will be loaded
667 # first, followed by the -source'd files.
670 # An appropriate "package ifneeded" statement for the package.
672 proc ::tcl::Pkg::Create {args
} {
673 append err
(usage
) "[lindex [info level 0] 0] "
674 append err
(usage
) "-name packageName -version packageVersion"
675 append err
(usage
) "?-load {filename ?{procs}?}? ... "
676 append err
(usage
) "?-source {filename ?{procs}?}? ..."
678 set err
(wrongNumArgs
) "wrong # args: should be \"$err(usage)\""
679 set err
(valueMissing
) "value for \"%s\" missing: should be \"$err(usage)\""
680 set err
(unknownOpt
) "unknown option \"%s\": should be \"$err(usage)\""
681 set err
(noLoadOrSource
) "at least one of -load and -source must be given"
684 set len
[llength $args]
686 error $err(wrongNumArgs
)
689 # Initialize parameters
691 set opts
(-version) {}
696 for {set i
0} {$i < $len} {incr i
} {
697 set flag
[lindex $args $i]
699 switch -glob -- $flag {
703 error [format $err(valueMissing
) $flag]
705 set opts
($flag) [lindex $args $i]
710 error [format $err(valueMissing
) $flag]
712 lappend opts
($flag) [lindex $args $i]
715 error [format $err(unknownOpt
) [lindex $args $i]]
720 # Validate the parameters
721 if { [llength $opts(-name)] == 0 } {
722 error [format $err(valueMissing
) "-name"]
724 if { [llength $opts(-version)] == 0 } {
725 error [format $err(valueMissing
) "-version"]
728 if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {
729 error $err(noLoadOrSource
)
732 # OK, now everything is good. Generate the package ifneeded statment.
733 set cmdline
"package ifneeded $opts(-name) $opts(-version) "
738 # Handle -load and -source specs
739 foreach key
{load source} {
740 foreach filespec
$opts(-$key) {
741 foreach {filename proclist
} {{} {}} {
744 foreach {filename proclist
} $filespec {
748 if { [llength $proclist] == 0 } {
749 set cmd
"\[list $key \[file join \$dir [list $filename]\]\]"
752 lappend lazyFileList
[list $filename $key $proclist]
757 if { [llength $lazyFileList] > 0 } {
758 lappend cmdList
"\[list tclPkgSetup \$dir $opts(-name)\
759 $opts(-version) [list $lazyFileList]\]"
761 append cmdline
[join $cmdList "\\n"]
765 interp alias
{} ::pkg::create {} ::tcl::Pkg::Create