diff -r 000000000000 -r bde4ae8d615e os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/library/package.tcl --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/library/package.tcl Fri Jun 15 03:10:57 2012 +0200 @@ -0,0 +1,828 @@ +# package.tcl -- +# +# utility procs formerly in init.tcl which can be loaded on demand +# for package management. +# +# RCS: @(#) $Id: package.tcl,v 1.23.2.4 2006/09/22 01:26:24 andreas_kupries Exp $ +# +# 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. +# + +# Create the package namespace +namespace eval ::pkg { +} + +# pkg_compareExtension -- +# +# Used internally by pkg_mkIndex to compare the extension of a file to +# a given extension. On Windows, it uses a case-insensitive comparison +# because the file system can be file insensitive. +# +# Arguments: +# fileName name of a file whose extension is compared +# ext (optional) The extension to compare against; you must +# provide the starting dot. +# Defaults to [info sharedlibextension] +# +# Results: +# Returns 1 if the extension matches, 0 otherwise + +proc pkg_compareExtension { fileName {ext {}} } { + global tcl_platform + if {$ext eq ""} {set ext [info sharedlibextension]} + if {$tcl_platform(platform) eq "windows"} { + return [string equal -nocase [file extension $fileName] $ext] + } else { + # Some unices add trailing numbers after the .so, so + # we could have something like '.so.1.2'. + set root $fileName + while {1} { + set currExt [file extension $root] + if {$currExt eq $ext} { + return 1 + } + + # The current extension does not match; if it is not a numeric + # value, quit, as we are only looking to ignore version number + # extensions. Otherwise we might return 1 in this case: + # pkg_compareExtension foo.so.bar .so + # which should not match. + + if { ![string is integer -strict [string range $currExt 1 end]] } { + return 0 + } + set root [file rootname $root] + } + } +} + +# 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: +# -direct (optional) If this flag is present, the generated +# code in pkgMkIndex.tcl will cause the package to be +# loaded when "package require" is executed, rather +# than lazily when the first reference to an exported +# procedure in the package is made. +# -verbose (optional) Verbose output; the name of each file that +# was successfully rocessed is printed out. Additionally, +# if processing of a file failed a message is printed. +# -load pat (optional) Preload any packages whose names match +# the pattern. Used to handle DLLs that depend on +# other packages during their Init procedure. +# 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 usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"}; + + set argCount [llength $args] + if {$argCount < 1} { + return -code error "wrong # args: should be\n$usage" + } + + set more "" + set direct 1 + set doVerbose 0 + set loadPat "" + for {set idx 0} {$idx < $argCount} {incr idx} { + set flag [lindex $args $idx] + switch -glob -- $flag { + -- { + # done with the flags + incr idx + break + } + -verbose { + set doVerbose 1 + } + -lazy { + set direct 0 + append more " -lazy" + } + -direct { + append more " -direct" + } + -load { + incr idx + set loadPat [lindex $args $idx] + append more " -load $loadPat" + } + -* { + return -code error "unknown flag $flag: should be\n$usage" + } + default { + # done with the flags + break + } + } + } + + set dir [lindex $args $idx] + set patternList [lrange $args [expr {$idx + 1}] end] + if {[llength $patternList] == 0} { + set patternList [list "*.tcl" "*[info sharedlibextension]"] + } + + set oldDir [pwd] + cd $dir + + if {[catch {eval [linsert $patternList 0 glob --]} fileList]} { + global errorCode errorInfo + cd $oldDir + return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList + } + foreach file $fileList { + # 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. + + if {$file eq "pkgIndex.tcl"} { + continue + } + + # Changed back to the original directory before initializing the + # slave in case TCL_LIBRARY is a relative path (e.g. in the test + # suite). + + cd $oldDir + set c [interp create] + + # Load into the child any packages currently loaded in the parent + # interpreter that match the -load pattern. + + if {$loadPat ne ""} { + if {$doVerbose} { + tclLog "currently loaded packages: '[info loaded]'" + tclLog "trying to load all packages matching $loadPat" + } + if {![llength [info loaded]]} { + tclLog "warning: no packages are currently loaded, nothing" + tclLog "can possibly match '$loadPat'" + } + } + foreach pkg [info loaded] { + if {! [string match -nocase $loadPat [lindex $pkg 1]]} { + continue + } + if {$doVerbose} { + tclLog "package [lindex $pkg 1] matches '$loadPat'" + } + if {[catch { + load [lindex $pkg 0] [lindex $pkg 1] $c + } err]} { + if {$doVerbose} { + tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err" + } + } elseif {$doVerbose} { + tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]" + } + if {[lindex $pkg 1] eq "Tk"} { + # Withdraw . if Tk was loaded, to avoid showing a window. + $c eval [list wm withdraw .] + } + } + cd $dir + + $c eval { + # Stub out the package command so packages can + # require other packages. + + rename package __package_orig + proc package {what args} { + switch -- $what { + require { return ; # ignore transitive requires } + default { uplevel 1 [linsert $args 0 __package_orig $what] } + } + } + proc tclPkgUnknown args {} + package unknown tclPkgUnknown + + # Stub out the unknown command so package can call + # into each other during their initialilzation. + + proc unknown {args} {} + + # Stub out the auto_import mechanism + + proc auto_import {args} {} + + # reserve the ::tcl namespace for support procs + # and temporary variables. This might make it awkward + # to generate a pkgIndex.tcl file for the ::tcl namespace. + + namespace eval ::tcl { + variable file ;# Current file being processed + variable direct ;# -direct flag value + variable x ;# Loop variable + variable debug ;# For debugging + variable type ;# "load" or "source", for -direct + variable namespaces ;# Existing namespaces (e.g., ::tcl) + variable packages ;# Existing packages (e.g., Tcl) + variable origCmds ;# Existing commands + variable newCmds ;# Newly created commands + variable newPkgs {} ;# Newly created packages + } + } + + $c eval [list set ::tcl::file $file] + $c eval [list set ::tcl::direct $direct] + + # Download needed procedures into the slave because we've + # just deleted the unknown procedure. This doesn't handle + # procedures with default arguments. + + foreach p {pkg_compareExtension} { + $c eval [list proc $p [info args $p] [info body $p]] + } + + if {[catch { + $c eval { + set ::tcl::debug "loading or sourcing" + + # we need to track command defined by each package even in + # the -direct case, because they are needed internally by + # the "partial pkgIndex.tcl" step above. + + proc ::tcl::GetAllNamespaces {{root ::}} { + set list $root + foreach ns [namespace children $root] { + eval [linsert [::tcl::GetAllNamespaces $ns] 0 \ + lappend list] + } + return $list + } + + # init the list of existing namespaces, packages, commands + + foreach ::tcl::x [::tcl::GetAllNamespaces] { + set ::tcl::namespaces($::tcl::x) 1 + } + foreach ::tcl::x [package names] { + if {[package provide $::tcl::x] ne ""} { + set ::tcl::packages($::tcl::x) 1 + } + } + set ::tcl::origCmds [info commands] + + # 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 {[pkg_compareExtension $::tcl::file [info sharedlibextension]]} { + # 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. + + set ::tcl::debug loading + load [file join . $::tcl::file] + set ::tcl::type load + } else { + set ::tcl::debug sourcing + source $::tcl::file + set ::tcl::type source + } + + # As a performance optimization, if we are creating + # direct load packages, don't bother figuring out the + # set of commands created by the new packages. We + # only need that list for setting up the autoloading + # used in the non-direct case. + if { !$::tcl::direct } { + # See what new namespaces appeared, and import commands + # from them. Only exported commands go into the index. + + foreach ::tcl::x [::tcl::GetAllNamespaces] { + if {! [info exists ::tcl::namespaces($::tcl::x)]} { + namespace import -force ${::tcl::x}::* + } + + # Figure out what commands appeared + + foreach ::tcl::x [info commands] { + set ::tcl::newCmds($::tcl::x) 1 + } + foreach ::tcl::x $::tcl::origCmds { + unset -nocomplain ::tcl::newCmds($::tcl::x) + } + foreach ::tcl::x [array names ::tcl::newCmds] { + # determine which namespace a command comes from + + set ::tcl::abs [namespace origin $::tcl::x] + + # special case so that global names have no leading + # ::, this is required by the unknown command + + set ::tcl::abs \ + [lindex [auto_qualify $::tcl::abs ::] 0] + + if {$::tcl::x ne $::tcl::abs} { + # Name changed during qualification + + set ::tcl::newCmds($::tcl::abs) 1 + unset ::tcl::newCmds($::tcl::x) + } + } + } + } + + # Look through the packages that appeared, and if there is + # a version provided, then record it + + foreach ::tcl::x [package names] { + if {[package provide $::tcl::x] ne "" + && ![info exists ::tcl::packages($::tcl::x)]} { + lappend ::tcl::newPkgs \ + [list $::tcl::x [package provide $::tcl::x]] + } + } + } + } msg] == 1} { + set what [$c eval set ::tcl::debug] + if {$doVerbose} { + tclLog "warning: error while $what $file: $msg" + } + } else { + set what [$c eval set ::tcl::debug] + if {$doVerbose} { + tclLog "successful $what of $file" + } + set type [$c eval set ::tcl::type] + set cmds [lsort [$c eval array names ::tcl::newCmds]] + set pkgs [$c eval set ::tcl::newPkgs] + if {$doVerbose} { + if { !$direct } { + tclLog "commands provided were $cmds" + } + tclLog "packages provided were $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] + } + + if {$doVerbose} { + tclLog "processed $file" + } + } + interp delete $c + } + + 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" + + foreach pkg [lsort [array names files]] { + set cmd {} + foreach {name version} $pkg { + break + } + lappend cmd ::pkg::create -name $name -version $version + foreach spec $files($pkg) { + foreach {file type procs} $spec { + if { $direct } { + set procs {} + } + lappend cmd "-$type" [list $file $procs] + } + } + append index "\n[eval $cmd]" + } + + 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 eq "load"} { + set auto_index($cmd) [list load [file join $dir $f] $pkg] + } else { + set auto_index($cmd) [list source [file join $dir $f]] + } + } + } +} + +# 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.) As it searches, it will recognize changes +# to the auto_path and scan any new directories. +# +# Arguments: +# name - Name of desired package. Not used. +# version - Version of desired package. Not used. +# exact - Either "-exact" or omitted. Not used. + + +proc tclPkgUnknown [expr { + [info exists tcl_platform(tip,268)] + ? "name args" + : "name version {exact {}}" + }] { + global auto_path env + + if {![info exists auto_path]} { + return + } + # Cache the auto_path, because it may change while we run through + # the first set of pkgIndex.tcl files + set old_path [set use_path $auto_path] + while {[llength $use_path]} { + set dir [lindex $use_path end] + + # Make sure we only scan each directory one time. + if {[info exists tclSeenPath($dir)]} { + set use_path [lrange $use_path 0 end-1] + continue + } + set tclSeenPath($dir) 1 + + # we can't use glob in safe interps, so enclose the following + # in a catch statement, where we get the pkgIndex files out + # of the subdirectories + catch { + foreach file [glob -directory $dir -join -nocomplain \ + * pkgIndex.tcl] { + set dir [file dirname $file] + if {![info exists procdDirs($dir)] && [file readable $file]} { + if {[catch {source $file} msg]} { + tclLog "error reading package index file $file: $msg" + } else { + set procdDirs($dir) 1 + } + } + } + } + set dir [lindex $use_path end] + if {![info exists procdDirs($dir)]} { + 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" + } else { + set procdDirs($dir) 1 + } + } + } + + set use_path [lrange $use_path 0 end-1] + + # Check whether any of the index scripts we [source]d above + # set a new value for $::auto_path. If so, then find any + # new directories on the $::auto_path, and lappend them to + # the $use_path we are working from. This gives index scripts + # the (arguably unwise) power to expand the index script search + # path while the search is in progress. + set index 0 + if {[llength $old_path] == [llength $auto_path]} { + foreach dir $auto_path old $old_path { + if {$dir ne $old} { + # This entry in $::auto_path has changed. + break + } + incr index + } + } + + # $index now points to the first element of $auto_path that + # has changed, or the beginning if $auto_path has changed length + # Scan the new elements of $auto_path for directories to add to + # $use_path. Don't add directories we've already seen, or ones + # already on the $use_path. + foreach dir [lrange $auto_path $index end] { + if {![info exists tclSeenPath($dir)] + && ([lsearch -exact $use_path $dir] == -1) } { + lappend use_path $dir + } + } + set old_path $auto_path + } +} + +# tcl::MacOSXPkgUnknown -- +# This procedure extends the "package unknown" function for MacOSX. +# It scans the Resources/Scripts directories of the immediate children +# of the auto_path directories for pkgIndex files. +# Only installed in interps that are not safe so we don't check +# for [interp issafe] as in tclPkgUnknown. +# +# Arguments: +# original - original [package unknown] procedure +# name - Name of desired package. Not used. +#ifndef TCL_TIP268 +# version - Version of desired package. Not used. +# exact - Either "-exact" or omitted. Not used. +#else +# args - List of requirements. Not used. +#endif + +if {[info exists tcl_platform(tip,268)]} { + proc tcl::MacOSXPkgUnknown {original name args} { + # First do the cross-platform default search + uplevel 1 $original [linsert $args 0 $name] + + # Now do MacOSX specific searching + global auto_path + + if {![info exists auto_path]} { + return + } + # Cache the auto_path, because it may change while we run through + # the first set of pkgIndex.tcl files + set old_path [set use_path $auto_path] + while {[llength $use_path]} { + set dir [lindex $use_path end] + # get the pkgIndex files out of the subdirectories + foreach file [glob -directory $dir -join -nocomplain \ + * Resources Scripts pkgIndex.tcl] { + set dir [file dirname $file] + if {[file readable $file] && ![info exists procdDirs($dir)]} { + if {[catch {source $file} msg]} { + tclLog "error reading package index file $file: $msg" + } else { + set procdDirs($dir) 1 + } + } + } + set use_path [lrange $use_path 0 end-1] + if {$old_path ne $auto_path} { + foreach dir $auto_path { + lappend use_path $dir + } + set old_path $auto_path + } + } + } +} else { + proc tcl::MacOSXPkgUnknown {original name version {exact {}}} { + + # First do the cross-platform default search + uplevel 1 $original [list $name $version $exact] + + # Now do MacOSX specific searching + global auto_path + + if {![info exists auto_path]} { + return + } + # Cache the auto_path, because it may change while we run through + # the first set of pkgIndex.tcl files + set old_path [set use_path $auto_path] + while {[llength $use_path]} { + set dir [lindex $use_path end] + # get the pkgIndex files out of the subdirectories + foreach file [glob -directory $dir -join -nocomplain \ + * Resources Scripts pkgIndex.tcl] { + set dir [file dirname $file] + if {[file readable $file] && ![info exists procdDirs($dir)]} { + if {[catch {source $file} msg]} { + tclLog "error reading package index file $file: $msg" + } else { + set procdDirs($dir) 1 + } + } + } + set use_path [lrange $use_path 0 end-1] + if {$old_path ne $auto_path} { + foreach dir $auto_path { + lappend use_path $dir + } + set old_path $auto_path + } + } + } +} + +# tcl::MacPkgUnknown -- +# This procedure extends the "package unknown" function for Mac. +# It searches for pkgIndex TEXT resources in all files +# Only installed in interps that are not safe so we don't check +# for [interp issafe] as in tclPkgUnknown. +# +# Arguments: +# original - original [package unknown] procedure +# name - Name of desired package. Not used. +# version - Version of desired package. Not used. +# exact - Either "-exact" or omitted. Not used. + +proc tcl::MacPkgUnknown {original name version {exact {}}} { + + # First do the cross-platform default search + uplevel 1 $original [list $name $version $exact] + + # Now do Mac specific searching + global auto_path + + if {![info exists auto_path]} { + return + } + # Cache the auto_path, because it may change while we run through + # the first set of pkgIndex.tcl files + set old_path [set use_path $auto_path] + while {[llength $use_path]} { + # We look for pkgIndex TEXT resources in the resource fork of shared libraries + set dir [lindex $use_path end] + foreach x [concat [list $dir] [glob -directory $dir -nocomplain *] ] { + if {[file isdirectory $x] && ![info exists procdDirs($x)]} { + set dir $x + foreach x [glob -directory $dir -nocomplain *.shlb] { + if {[file isfile $x]} { + set res [resource open $x] + foreach y [resource list TEXT $res] { + if {$y eq "pkgIndex"} {source -rsrc pkgIndex} + } + catch {resource close $res} + } + } + set procdDirs($dir) 1 + } + } + set use_path [lrange $use_path 0 end-1] + if {$old_path ne $auto_path} { + foreach dir $auto_path { + lappend use_path $dir + } + set old_path $auto_path + } + } +} + +# ::pkg::create -- +# +# Given a package specification generate a "package ifneeded" statement +# for the package, suitable for inclusion in a pkgIndex.tcl file. +# +# Arguments: +# args arguments used by the create function: +# -name packageName +# -version packageVersion +# -load {filename ?{procs}?} +# ... +# -source {filename ?{procs}?} +# ... +# +# Any number of -load and -source parameters may be +# specified, so long as there is at least one -load or +# -source parameter. If the procs component of a +# module specifier is left off, that module will be +# set up for direct loading; otherwise, it will be +# set up for lazy loading. If both -source and -load +# are specified, the -load'ed files will be loaded +# first, followed by the -source'd files. +# +# Results: +# An appropriate "package ifneeded" statement for the package. + +proc ::pkg::create {args} { + append err(usage) "[lindex [info level 0] 0] " + append err(usage) "-name packageName -version packageVersion" + append err(usage) "?-load {filename ?{procs}?}? ... " + append err(usage) "?-source {filename ?{procs}?}? ..." + + set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\"" + set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\"" + set err(unknownOpt) "unknown option \"%s\": should be \"$err(usage)\"" + set err(noLoadOrSource) "at least one of -load and -source must be given" + + # process arguments + set len [llength $args] + if { $len < 6 } { + error $err(wrongNumArgs) + } + + # Initialize parameters + set opts(-name) {} + set opts(-version) {} + set opts(-source) {} + set opts(-load) {} + + # process parameters + for {set i 0} {$i < $len} {incr i} { + set flag [lindex $args $i] + incr i + switch -glob -- $flag { + "-name" - + "-version" { + if { $i >= $len } { + error [format $err(valueMissing) $flag] + } + set opts($flag) [lindex $args $i] + } + "-source" - + "-load" { + if { $i >= $len } { + error [format $err(valueMissing) $flag] + } + lappend opts($flag) [lindex $args $i] + } + default { + error [format $err(unknownOpt) [lindex $args $i]] + } + } + } + + # Validate the parameters + if { [llength $opts(-name)] == 0 } { + error [format $err(valueMissing) "-name"] + } + if { [llength $opts(-version)] == 0 } { + error [format $err(valueMissing) "-version"] + } + + if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } { + error $err(noLoadOrSource) + } + + # OK, now everything is good. Generate the package ifneeded statment. + set cmdline "package ifneeded $opts(-name) $opts(-version) " + + set cmdList {} + set lazyFileList {} + + # Handle -load and -source specs + foreach key {load source} { + foreach filespec $opts(-$key) { + foreach {filename proclist} {{} {}} { + break + } + foreach {filename proclist} $filespec { + break + } + + if { [llength $proclist] == 0 } { + set cmd "\[list $key \[file join \$dir [list $filename]\]\]" + lappend cmdList $cmd + } else { + lappend lazyFileList [list $filename $key $proclist] + } + } + } + + if { [llength $lazyFileList] > 0 } { + lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\ + $opts(-version) [list $lazyFileList]\]" + } + append cmdline [join $cmdList "\\n"] + return $cmdline +} +