Upgrade to Tcl/Tk 8.5b2

[msysgit.git] / mingw / lib / tcl8.5 / package.tcl

# package.tcl --
#
# utility procs formerly in init.tcl which can be loaded on demand
# for package management.
#
# RCS: @(#) $Id: package.tcl,v 1.35 2006/11/03 00:34:52 hobbs 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.
#

namespace eval tcl::Pkg {}

# ::tcl::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 tcl::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:
            #           tcl::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} {
    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]"]
    }

    if {[catch {
            glob -directory $dir -tails -types {r f} -- {*}$patternList
    } fileList o]} {
        return -options $o $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
        }

        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 .]
            }
        }

        $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 { __package_orig $what {*}$args }
                }
            }
            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 dir            ;# Current directory being processed
                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::dir $dir]
        $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 {::tcl::Pkg::CompareExtension} {
            $c eval [list namespace eval [namespace qualifiers $p] {}]
            $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] {
                        lappend list {*}[::tcl::GetAllNamespaces $ns]
                    }
                    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 {[::tcl::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::dir $::tcl::file]
                    set ::tcl::type load
                } else {
                    set ::tcl::debug sourcing
                    source [file join $::tcl::dir $::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 ::tcl::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 [file join $dir pkgIndex.tcl] w]
    puts $f $index
    close $f
}

# 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. 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 {name args} {
    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.
# version -             Version of desired package.  Not used.
# exact -               Either "-exact" or omitted.  Not used.

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]

        # 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

        # 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 {![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 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::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 ::tcl::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
}

interp alias {} ::pkg::create {} ::tcl::Pkg::Create