diff options
Diffstat (limited to 'library/package.tcl')
| -rw-r--r-- | library/package.tcl | 302 |
1 files changed, 302 insertions, 0 deletions
diff --git a/library/package.tcl b/library/package.tcl new file mode 100644 index 0000000..68c5053 --- /dev/null +++ b/library/package.tcl @@ -0,0 +1,302 @@ +# package.tcl -- +# +# utility procs formerly in init.tcl which can be loaded on demand +# for package management. +# +# SCCS: @(#) package.tcl 1.5 98/01/28 17:07:30 +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1998 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# pkg_mkIndex -- +# This procedure creates a package index in a given directory. The +# package index consists of a "pkgIndex.tcl" file whose contents are +# a Tcl script that sets up package information with "package require" +# commands. The commands describe all of the packages defined by the +# files given as arguments. +# +# Arguments: +# dir - Name of the directory in which to create the index. +# args - Any number of additional arguments, each giving +# a glob pattern that matches the names of one or +# more shared libraries or Tcl script files in +# dir. + +proc pkg_mkIndex {args} { + global errorCode errorInfo + set first [lindex $args 0] + set direct [string match "-d*" $first] + set more "" + if {$direct} { + set args [lrange $args 1 end] + set more " -direct" + } + if {[llength $args] == 0} { + return -code error "wrong # args: should be\ + \"pkg_mkIndex ?-direct? dir ?pattern ...?\""; + } + set dir [lindex $args 0] + set patternList [lrange $args 1 end] + if {[llength $patternList] == 0} { + set patternList [list "*.tcl" "*[info sharedlibextension]"] + } + append index "# Tcl package index file, version 1.1\n" + append index "# This file is generated by the \"pkg_mkIndex$more\" command\n" + append index "# and sourced either when an application starts up or\n" + append index "# by a \"package unknown\" script. It invokes the\n" + append index "# \"package ifneeded\" command to set up package-related\n" + append index "# information so that packages will be loaded automatically\n" + append index "# in response to \"package require\" commands. When this\n" + append index "# script is sourced, the variable \$dir must contain the\n" + append index "# full path name of this file's directory.\n" + set oldDir [pwd] + cd $dir + foreach file [eval glob $patternList] { + # For each file, figure out what commands and packages it provides. + # To do this, create a child interpreter, load the file into the + # interpreter, and get a list of the new commands and packages + # that are defined. Define an empty "package unknown" script so + # that there are no recursive package inclusions. + + set c [interp create] + + # If Tk is loaded in the parent interpreter, load it into the + # child also, in case the extension depends on it. + + foreach pkg [info loaded] { + if {[lindex $pkg 1] == "Tk"} { + $c eval {set argv {-geometry +0+0}} + load [lindex $pkg 0] Tk $c + break + } + } + $c eval [list set __file $file] + $c eval [list set __direct $direct] + if {[catch { + $c eval { + proc __dummy args {} + rename package __package_orig + proc package {what args} { + switch -- $what { + require { return ; # ignore transitive requires } + default { eval __package_orig [list $what] $args } + } + } + if {!$__direct} { + proc __pkgGetAllNamespaces {{root {}}} { + set list $root + foreach ns [namespace children $root] { + eval lappend list [__pkgGetAllNamespaces $ns] + } + return $list + } + set __origCmds [info commands] + } + package unknown __dummy + + set dir "" ;# in case file is pkgIndex.tcl + + # Try to load the file if it has the shared library extension, + # otherwise source it. It's important not to try to load + # files that aren't shared libraries, because on some systems + # (like SunOS) the loader will abort the whole application + # when it gets an error. + + if {[string compare [file extension $__file] \ + [info sharedlibextension]] == 0} { + + # The "file join ." command below is necessary. Without + # it, if the file name has no \'s and we're on UNIX, the + # load command will invoke the LD_LIBRARY_PATH search + # mechanism, which could cause the wrong file to be used. + + if {[catch {load [file join . $__file]} __msg]} { + tclLog "warning: error while loading $__file: $__msg" + } + set __type load + } else { + if {[catch {source $__file} __msg]} { + tclLog "warning: error while sourcing $__file: $__msg" + } + set __type source + } + # Using __ variable names to avoid potential namespaces + # clash, even here in post processing because the + # loaded package could have set up traces,... + if {!$__direct} { + foreach __ns [__pkgGetAllNamespaces] { + namespace import ${__ns}::* + } + foreach __i [info commands] { + set __cmds($__i) 1 + } + foreach __i $__origCmds { + catch {unset __cmds($__i)} + } + foreach __i [array names __cmds] { + # reverse engineer which namespace a command comes from + set __absolute [namespace origin $__i] + if {[string compare ::$__i $__absolute] != 0} { + set __cmds($__absolute) 1 + unset __cmds($__i) + } + } + } + set __pkgs {} + foreach __i [package names] { + if {([string compare [package provide $__i] ""] != 0) + && ([string compare $__i Tcl] != 0) + && ([string compare $__i Tk] != 0)} { + lappend __pkgs [list $__i [package provide $__i]] + } + } + } + } msg]} { + tclLog "error while loading or sourcing $file: $msg" + } + set type [$c eval set __type] + set cmds [lsort [$c eval array names __cmds]] + set pkgs [$c eval set __pkgs] + if {[llength $pkgs] > 1} { + tclLog "warning: \"$file\" provides more than one package ($pkgs)" + } + foreach pkg $pkgs { + # cmds is empty/not used in the direct case + lappend files($pkg) [list $file $type $cmds] + } + interp delete $c + } + foreach pkg [lsort [array names files]] { + append index "\npackage ifneeded $pkg " + if {$direct} { + set cmdList {} + foreach elem $files($pkg) { + set file [lindex $elem 0] + set type [lindex $elem 1] + lappend cmdList "\[list $type \[file join \$dir\ + [list $file]\]\]" + } + append index [join $cmdList "\\n"] + } else { + append index "\[list tclPkgSetup \$dir [lrange $pkg 0 0]\ + [lrange $pkg 1 1] [list $files($pkg)]\]" + } + } + set f [open pkgIndex.tcl w] + puts $f $index + close $f + cd $oldDir +} + +# tclPkgSetup -- +# This is a utility procedure use by pkgIndex.tcl files. It is invoked +# as part of a "package ifneeded" script. It calls "package provide" +# to indicate that a package is available, then sets entries in the +# auto_index array so that the package's files will be auto-loaded when +# the commands are used. +# +# Arguments: +# dir - Directory containing all the files for this package. +# pkg - Name of the package (no version number). +# version - Version number for the package, such as 2.1.3. +# files - List of files that constitute the package. Each +# element is a sub-list with three elements. The first +# is the name of a file relative to $dir, the second is +# "load" or "source", indicating whether the file is a +# loadable binary or a script to source, and the third +# is a list of commands defined by this file. + +proc tclPkgSetup {dir pkg version files} { + global auto_index + + package provide $pkg $version + foreach fileInfo $files { + set f [lindex $fileInfo 0] + set type [lindex $fileInfo 1] + foreach cmd [lindex $fileInfo 2] { + if {$type == "load"} { + set auto_index($cmd) [list load [file join $dir $f] $pkg] + } else { + set auto_index($cmd) [list source [file join $dir $f]] + } + } + } +} + +# tclMacPkgSearch -- +# The procedure is used on the Macintosh to search a given directory for files +# with a TEXT resource named "pkgIndex". If it exists it is sourced in to the +# interpreter to setup the package database. + +proc tclMacPkgSearch {dir} { + foreach x [glob -nocomplain [file join $dir *.shlb]] { + if {[file isfile $x]} { + set res [resource open $x] + foreach y [resource list TEXT $res] { + if {$y == "pkgIndex"} {source -rsrc pkgIndex} + } + catch {resource close $res} + } + } +} + +# tclPkgUnknown -- +# This procedure provides the default for the "package unknown" function. +# It is invoked when a package that's needed can't be found. It scans +# the auto_path directories and their immediate children looking for +# pkgIndex.tcl files and sources any such files that are found to setup +# the package database. (On the Macintosh we also search for pkgIndex +# TEXT resources in all files.) +# +# Arguments: +# name - Name of desired package. Not used. +# version - Version of desired package. Not used. +# exact - Either "-exact" or omitted. Not used. + +proc tclPkgUnknown {name version {exact {}}} { + global auto_path tcl_platform env + + if {![info exists auto_path]} { + return + } + for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} { + # we can't use glob in safe interps, so enclose the following + # in a catch statement + catch { + foreach file [glob -nocomplain [file join [lindex $auto_path $i] \ + * pkgIndex.tcl]] { + set dir [file dirname $file] + if {[catch {source $file} msg]} { + tclLog "error reading package index file $file: $msg" + } + } + } + set dir [lindex $auto_path $i] + set file [file join $dir pkgIndex.tcl] + # safe interps usually don't have "file readable", nor stderr channel + if {[interp issafe] || [file readable $file]} { + if {[catch {source $file} msg] && ![interp issafe]} { + tclLog "error reading package index file $file: $msg" + } + } + # On the Macintosh we also look in the resource fork + # of shared libraries + # We can't use tclMacPkgSearch in safe interps because it uses glob + if {(![interp issafe]) && ($tcl_platform(platform) == "macintosh")} { + set dir [lindex $auto_path $i] + tclMacPkgSearch $dir + foreach x [glob -nocomplain [file join $dir *]] { + if {[file isdirectory $x]} { + set dir $x + tclMacPkgSearch $dir + } + } + } + } +} + + |