home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / tcltk / tcl8.5 / package.tcl < prev    next >
Encoding:
Text File  |  2009-11-22  |  23.1 KB  |  766 lines
  1. # package.tcl --
  2. #
  3. # utility procs formerly in init.tcl which can be loaded on demand
  4. # for package management.
  5. #
  6. # RCS: @(#) $Id: package.tcl,v 1.35.4.1 2008/07/03 17:22:59 dgp Exp $
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994-1998 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15. namespace eval tcl::Pkg {}
  16.  
  17. # ::tcl::Pkg::CompareExtension --
  18. #
  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.
  22. #
  23. # Arguments:
  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]
  28. #
  29. # Results:
  30. #  Returns 1 if the extension matches, 0 otherwise
  31.  
  32. proc tcl::Pkg::CompareExtension { fileName {ext {}} } {
  33.     global tcl_platform
  34.     if {$ext eq ""} {set ext [info sharedlibextension]}
  35.     if {$tcl_platform(platform) eq "windows"} {
  36.         return [string equal -nocase [file extension $fileName] $ext]
  37.     } else {
  38.         # Some unices add trailing numbers after the .so, so
  39.         # we could have something like '.so.1.2'.
  40.         set root $fileName
  41.         while {1} {
  42.             set currExt [file extension $root]
  43.             if {$currExt eq $ext} {
  44.                 return 1
  45.             } 
  46.  
  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.
  52.  
  53.         if { ![string is integer -strict [string range $currExt 1 end]] } {
  54.         return 0
  55.         }
  56.             set root [file rootname $root]
  57.     }
  58.     }
  59. }
  60.  
  61. # pkg_mkIndex --
  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.
  67. #
  68. # 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
  84. #            dir.
  85.  
  86. proc pkg_mkIndex {args} {
  87.     set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"};
  88.  
  89.     set argCount [llength $args]
  90.     if {$argCount < 1} {
  91.     return -code error "wrong # args: should be\n$usage"
  92.     }
  93.  
  94.     set more ""
  95.     set direct 1
  96.     set doVerbose 0
  97.     set loadPat ""
  98.     for {set idx 0} {$idx < $argCount} {incr idx} {
  99.     set flag [lindex $args $idx]
  100.     switch -glob -- $flag {
  101.         -- {
  102.         # done with the flags
  103.         incr idx
  104.         break
  105.         }
  106.         -verbose {
  107.         set doVerbose 1
  108.         }
  109.         -lazy {
  110.         set direct 0
  111.         append more " -lazy"
  112.         }
  113.         -direct {
  114.         append more " -direct"
  115.         }
  116.         -load {
  117.         incr idx
  118.         set loadPat [lindex $args $idx]
  119.         append more " -load $loadPat"
  120.         }
  121.         -* {
  122.         return -code error "unknown flag $flag: should be\n$usage"
  123.         }
  124.         default {
  125.         # done with the flags
  126.         break
  127.         }
  128.     }
  129.     }
  130.  
  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]"]
  135.     }
  136.  
  137.     if {[catch {
  138.         glob -directory $dir -tails -types {r f} -- {*}$patternList
  139.     } fileList o]} {
  140.     return -options $o $fileList
  141.     }
  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
  146.     # that are defined.
  147.  
  148.     if {$file eq "pkgIndex.tcl"} {
  149.         continue
  150.     }
  151.  
  152.     set c [interp create]
  153.  
  154.     # Load into the child any packages currently loaded in the parent
  155.     # interpreter that match the -load pattern.
  156.  
  157.     if {$loadPat ne ""} {
  158.         if {$doVerbose} {
  159.         tclLog "currently loaded packages: '[info loaded]'"
  160.         tclLog "trying to load all packages matching $loadPat"
  161.         }
  162.         if {![llength [info loaded]]} {
  163.         tclLog "warning: no packages are currently loaded, nothing"
  164.         tclLog "can possibly match '$loadPat'"
  165.         }
  166.     }
  167.     foreach pkg [info loaded] {
  168.         if {! [string match -nocase $loadPat [lindex $pkg 1]]} {
  169.         continue
  170.         }
  171.         if {$doVerbose} {
  172.         tclLog "package [lindex $pkg 1] matches '$loadPat'"
  173.         }
  174.         if {[catch {
  175.         load [lindex $pkg 0] [lindex $pkg 1] $c
  176.         } err]} {
  177.         if {$doVerbose} {
  178.             tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
  179.         }
  180.         } elseif {$doVerbose} {
  181.         tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
  182.         }
  183.         if {[lindex $pkg 1] eq "Tk"} {
  184.         # Withdraw . if Tk was loaded, to avoid showing a window.
  185.         $c eval [list wm withdraw .]
  186.         }
  187.     }
  188.  
  189.     $c eval {
  190.         # Stub out the package command so packages can
  191.         # require other packages.
  192.  
  193.         rename package __package_orig
  194.         proc package {what args} {
  195.         switch -- $what {
  196.             require { return ; # ignore transitive requires }
  197.             default { __package_orig $what {*}$args }
  198.         }
  199.         }
  200.         proc tclPkgUnknown args {}
  201.         package unknown tclPkgUnknown
  202.  
  203.         # Stub out the unknown command so package can call
  204.         # into each other during their initialilzation.
  205.  
  206.         proc unknown {args} {}
  207.  
  208.         # Stub out the auto_import mechanism
  209.  
  210.         proc auto_import {args} {}
  211.  
  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.
  215.  
  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
  228.         }
  229.     }
  230.  
  231.     $c eval [list set ::tcl::dir $dir]
  232.     $c eval [list set ::tcl::file $file]
  233.     $c eval [list set ::tcl::direct $direct]
  234.  
  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.
  238.  
  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]]
  242.     }
  243.  
  244.     if {[catch {
  245.         $c eval {
  246.         set ::tcl::debug "loading or sourcing"
  247.  
  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.
  251.  
  252.         proc ::tcl::GetAllNamespaces {{root ::}} {
  253.             set list $root
  254.             foreach ns [namespace children $root] {
  255.             lappend list {*}[::tcl::GetAllNamespaces $ns]
  256.             }
  257.             return $list
  258.         }
  259.  
  260.         # init the list of existing namespaces, packages, commands
  261.  
  262.         foreach ::tcl::x [::tcl::GetAllNamespaces] {
  263.             set ::tcl::namespaces($::tcl::x) 1
  264.         }
  265.         foreach ::tcl::x [package names] {
  266.             if {[package provide $::tcl::x] ne ""} {
  267.             set ::tcl::packages($::tcl::x) 1
  268.             }
  269.         }
  270.         set ::tcl::origCmds [info commands]
  271.  
  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.
  277.  
  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.
  284.  
  285.             set ::tcl::debug loading
  286.             load [file join $::tcl::dir $::tcl::file]
  287.             set ::tcl::type load
  288.         } else {
  289.             set ::tcl::debug sourcing
  290.             source [file join $::tcl::dir $::tcl::file]
  291.             set ::tcl::type source
  292.         }
  293.  
  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.
  302.             
  303.             foreach ::tcl::x [::tcl::GetAllNamespaces] {
  304.             if {! [info exists ::tcl::namespaces($::tcl::x)]} {
  305.                 namespace import -force ${::tcl::x}::*
  306.             }
  307.  
  308.             # Figure out what commands appeared
  309.             
  310.             foreach ::tcl::x [info commands] {
  311.                 set ::tcl::newCmds($::tcl::x) 1
  312.             }
  313.             foreach ::tcl::x $::tcl::origCmds {
  314.                 unset -nocomplain ::tcl::newCmds($::tcl::x)
  315.             }
  316.             foreach ::tcl::x [array names ::tcl::newCmds] {
  317.                 # determine which namespace a command comes from
  318.                 
  319.                 set ::tcl::abs [namespace origin $::tcl::x]
  320.                 
  321.                 # special case so that global names have no leading
  322.                 # ::, this is required by the unknown command
  323.                 
  324.                 set ::tcl::abs \
  325.                     [lindex [auto_qualify $::tcl::abs ::] 0]
  326.                 
  327.                 if {$::tcl::x ne $::tcl::abs} {
  328.                 # Name changed during qualification
  329.                 
  330.                 set ::tcl::newCmds($::tcl::abs) 1
  331.                 unset ::tcl::newCmds($::tcl::x)
  332.                 }
  333.             }
  334.             }
  335.         }
  336.  
  337.         # Look through the packages that appeared, and if there is
  338.         # a version provided, then record it
  339.  
  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]]
  345.             }
  346.         }
  347.         }
  348.     } msg] == 1} {
  349.         set what [$c eval set ::tcl::debug]
  350.         if {$doVerbose} {
  351.         tclLog "warning: error while $what $file: $msg"
  352.         }
  353.     } else {
  354.         set what [$c eval set ::tcl::debug]
  355.         if {$doVerbose} {
  356.         tclLog "successful $what of $file"
  357.         }
  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]
  361.         if {$doVerbose} {
  362.         if { !$direct } {
  363.             tclLog "commands provided were $cmds"
  364.         }
  365.         tclLog "packages provided were $pkgs"
  366.         }
  367.         if {[llength $pkgs] > 1} {
  368.         tclLog "warning: \"$file\" provides more than one package ($pkgs)"
  369.         }
  370.         foreach pkg $pkgs {
  371.         # cmds is empty/not used in the direct case
  372.         lappend files($pkg) [list $file $type $cmds]
  373.         }
  374.  
  375.         if {$doVerbose} {
  376.         tclLog "processed $file"
  377.         }
  378.     }
  379.     interp delete $c
  380.     }
  381.  
  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"
  391.  
  392.     foreach pkg [lsort [array names files]] {
  393.     set cmd {}
  394.     foreach {name version} $pkg {
  395.         break
  396.     }
  397.     lappend cmd ::tcl::Pkg::Create -name $name -version $version
  398.     foreach spec $files($pkg) {
  399.         foreach {file type procs} $spec {
  400.         if { $direct } {
  401.             set procs {}
  402.         }
  403.         lappend cmd "-$type" [list $file $procs]
  404.         }
  405.     }
  406.     append index "\n[eval $cmd]"
  407.     }
  408.  
  409.     set f [open [file join $dir pkgIndex.tcl] w]
  410.     puts $f $index
  411.     close $f
  412. }
  413.  
  414. # tclPkgSetup --
  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.
  420. #
  421. # Arguments:
  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.
  431.  
  432. proc tclPkgSetup {dir pkg version files} {
  433.     global auto_index
  434.  
  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]
  442.         } else {
  443.         set auto_index($cmd) [list source [file join $dir $f]]
  444.         } 
  445.     }
  446.     }
  447. }
  448.  
  449. # tclPkgUnknown --
  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.
  456. #
  457. # Arguments:
  458. # name -        Name of desired package.  Not used.
  459. # version -        Version of desired package.  Not used.
  460. # exact -        Either "-exact" or omitted.  Not used.
  461.  
  462. proc tclPkgUnknown {name args} {
  463.     global auto_path env
  464.  
  465.     if {![info exists auto_path]} {
  466.     return
  467.     }
  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]
  473.     
  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]
  477.         continue
  478.     }
  479.     set tclSeenPath($dir) 1
  480.  
  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
  484.     catch {
  485.         foreach file [glob -directory $dir -join -nocomplain \
  486.             * pkgIndex.tcl] {
  487.         set dir [file dirname $file]
  488.         if {![info exists procdDirs($dir)]} {
  489.             set code [catch {source $file} msg opt]
  490.             if {$code == 1 &&
  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
  494.             continue
  495.             }
  496.             if {$code} {
  497.             tclLog "error reading package index file $file: $msg"
  498.             } else {
  499.             set procdDirs($dir) 1
  500.             }
  501.         }
  502.         }
  503.     }
  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]
  510.         if {$code == 1 &&
  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
  514.             continue
  515.         }
  516.         if {$code}  {
  517.             tclLog "error reading package index file $file: $msg"
  518.         } else {
  519.             set procdDirs($dir) 1
  520.         }
  521.         }
  522.     }
  523.  
  524.     set use_path [lrange $use_path 0 end-1]
  525.  
  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.
  532.     set index 0
  533.     if {[llength $old_path] == [llength $auto_path]} {
  534.         foreach dir $auto_path old $old_path {
  535.         if {$dir ne $old} {
  536.             # This entry in $::auto_path has changed.
  537.             break
  538.         }
  539.         incr index
  540.         }
  541.     }
  542.  
  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
  552.         }
  553.     }
  554.     set old_path $auto_path
  555.     }
  556. }
  557.  
  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.
  562. #
  563. # Arguments:
  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.
  568.  
  569. proc tcl::MacOSXPkgUnknown {original name args} {
  570.  
  571.     #  First do the cross-platform default search
  572.     uplevel 1 $original [linsert $args 0 $name]
  573.  
  574.     # Now do MacOSX specific searching
  575.     global auto_path
  576.  
  577.     if {![info exists auto_path]} {
  578.     return
  579.     }
  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]
  585.  
  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]
  589.         continue
  590.     }
  591.     set tclSeenPath($dir) 1
  592.  
  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]
  599.         if {$code == 1 &&
  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
  603.             continue
  604.         }
  605.         if {$code} {
  606.             tclLog "error reading package index file $file: $msg"
  607.         } else {
  608.             set procdDirs($dir) 1
  609.         }
  610.         }
  611.     }
  612.     set use_path [lrange $use_path 0 end-1]
  613.  
  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.
  620.     set index 0
  621.     if {[llength $old_path] == [llength $auto_path]} {
  622.         foreach dir $auto_path old $old_path {
  623.         if {$dir ne $old} {
  624.             # This entry in $::auto_path has changed.
  625.             break
  626.         }
  627.         incr index
  628.         }
  629.     }
  630.  
  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
  640.         }
  641.     }
  642.     set old_path $auto_path
  643.     }
  644. }
  645.  
  646. # ::tcl::Pkg::Create --
  647. #
  648. #    Given a package specification generate a "package ifneeded" statement
  649. #    for the package, suitable for inclusion in a pkgIndex.tcl file.
  650. #
  651. # Arguments:
  652. #    args        arguments used by the Create function:
  653. #            -name        packageName
  654. #            -version    packageVersion
  655. #            -load        {filename ?{procs}?}
  656. #            ...
  657. #            -source        {filename ?{procs}?}
  658. #            ...
  659. #
  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.
  668. #
  669. # Results:
  670. #    An appropriate "package ifneeded" statement for the package.
  671.  
  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}?}? ..."
  677.  
  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"
  682.  
  683.     # process arguments
  684.     set len [llength $args]
  685.     if { $len < 6 } {
  686.     error $err(wrongNumArgs)
  687.     }
  688.     
  689.     # Initialize parameters
  690.     set opts(-name)        {}
  691.     set opts(-version)        {}
  692.     set opts(-source)        {}
  693.     set opts(-load)        {}
  694.  
  695.     # process parameters
  696.     for {set i 0} {$i < $len} {incr i} {
  697.     set flag [lindex $args $i]
  698.     incr i
  699.     switch -glob -- $flag {
  700.         "-name"        -
  701.         "-version"        {
  702.         if { $i >= $len } {
  703.             error [format $err(valueMissing) $flag]
  704.         }
  705.         set opts($flag) [lindex $args $i]
  706.         }
  707.         "-source"        -
  708.         "-load"        {
  709.         if { $i >= $len } {
  710.             error [format $err(valueMissing) $flag]
  711.         }
  712.         lappend opts($flag) [lindex $args $i]
  713.         }
  714.         default {
  715.         error [format $err(unknownOpt) [lindex $args $i]]
  716.         }
  717.     }
  718.     }
  719.  
  720.     # Validate the parameters
  721.     if { [llength $opts(-name)] == 0 } {
  722.     error [format $err(valueMissing) "-name"]
  723.     }
  724.     if { [llength $opts(-version)] == 0 } {
  725.     error [format $err(valueMissing) "-version"]
  726.     }
  727.     
  728.     if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {
  729.     error $err(noLoadOrSource)
  730.     }
  731.  
  732.     # OK, now everything is good.  Generate the package ifneeded statment.
  733.     set cmdline "package ifneeded $opts(-name) $opts(-version) "
  734.     
  735.     set cmdList {}
  736.     set lazyFileList {}
  737.  
  738.     # Handle -load and -source specs
  739.     foreach key {load source} {
  740.     foreach filespec $opts(-$key) {
  741.         foreach {filename proclist} {{} {}} {
  742.         break
  743.         }
  744.         foreach {filename proclist} $filespec {
  745.         break
  746.         }
  747.         
  748.         if { [llength $proclist] == 0 } {
  749.         set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
  750.         lappend cmdList $cmd
  751.         } else {
  752.         lappend lazyFileList [list $filename $key $proclist]
  753.         }
  754.     }
  755.     }
  756.  
  757.     if { [llength $lazyFileList] > 0 } {
  758.     lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
  759.         $opts(-version) [list $lazyFileList]\]"
  760.     }
  761.     append cmdline [join $cmdList "\\n"]
  762.     return $cmdline
  763. }
  764.  
  765. interp alias {} ::pkg::create {} ::tcl::Pkg::Create 
  766.