source: proiecte/pmake3d/make3d_original/Make3dSingleImageStanford_version0.1/third_party/vrippack-0.31/lib/linux/tcl8.4/package.tcl @ 37

Last change on this file since 37 was 37, checked in by (none), 14 years ago

Added original make3d
File size: 23.4 KB
Line 
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.23.2.2 2003/07/24 08:23:17 rmax 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# Create the package namespace
16namespace eval ::pkg {
17}
18
19# pkg_compareExtension --
20#
21#  Used internally by pkg_mkIndex to compare the extension of a file to
22#  a given extension. On Windows, it uses a case-insensitive comparison
23#  because the file system can be file insensitive.
24#
25# Arguments:
26#  fileName     name of a file whose extension is compared
27#  ext          (optional) The extension to compare against; you must
28#               provide the starting dot.
29#               Defaults to [info sharedlibextension]
30#
31# Results:
32#  Returns 1 if the extension matches, 0 otherwise
33
34proc pkg_compareExtension { fileName {ext {}} } {
35    global tcl_platform
36    if {![string length $ext]} {set ext [info sharedlibextension]}
37    if {[string equal $tcl_platform(platform) "windows"]} {
38        return [string equal -nocase [file extension $fileName] $ext]
39    } else {
40        # Some unices add trailing numbers after the .so, so
41        # we could have something like '.so.1.2'.
42        set root $fileName
43        while {1} {
44            set currExt [file extension $root]
45            if {[string equal $currExt $ext]} {
46                return 1
47            } 
48
49            # The current extension does not match; if it is not a numeric
50            # value, quit, as we are only looking to ignore version number
51            # extensions.  Otherwise we might return 1 in this case:
52            #           pkg_compareExtension foo.so.bar .so
53            # which should not match.
54
55            if { ![string is integer -strict [string range $currExt 1 end]] } {
56                return 0
57            }
58            set root [file rootname $root]
59        }
60    }
61}
62
63# pkg_mkIndex --
64# This procedure creates a package index in a given directory.  The
65# package index consists of a "pkgIndex.tcl" file whose contents are
66# a Tcl script that sets up package information with "package require"
67# commands.  The commands describe all of the packages defined by the
68# files given as arguments.
69#
70# Arguments:
71# -direct               (optional) If this flag is present, the generated
72#                       code in pkgMkIndex.tcl will cause the package to be
73#                       loaded when "package require" is executed, rather
74#                       than lazily when the first reference to an exported
75#                       procedure in the package is made.
76# -verbose              (optional) Verbose output; the name of each file that
77#                       was successfully rocessed is printed out. Additionally,
78#                       if processing of a file failed a message is printed.
79# -load pat             (optional) Preload any packages whose names match
80#                       the pattern.  Used to handle DLLs that depend on
81#                       other packages during their Init procedure.
82# dir -                 Name of the directory in which to create the index.
83# args -                Any number of additional arguments, each giving
84#                       a glob pattern that matches the names of one or
85#                       more shared libraries or Tcl script files in
86#                       dir.
87
88proc pkg_mkIndex {args} {
89    global errorCode errorInfo
90    set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"};
91
92    set argCount [llength $args]
93    if {$argCount < 1} {
94        return -code error "wrong # args: should be\n$usage"
95    }
96
97    set more ""
98    set direct 1
99    set doVerbose 0
100    set loadPat ""
101    for {set idx 0} {$idx < $argCount} {incr idx} {
102        set flag [lindex $args $idx]
103        switch -glob -- $flag {
104            -- {
105                # done with the flags
106                incr idx
107                break
108            }
109            -verbose {
110                set doVerbose 1
111            }
112            -lazy {
113                set direct 0
114                append more " -lazy"
115            }
116            -direct {
117                append more " -direct"
118            }
119            -load {
120                incr idx
121                set loadPat [lindex $args $idx]
122                append more " -load $loadPat"
123            }
124            -* {
125                return -code error "unknown flag $flag: should be\n$usage"
126            }
127            default {
128                # done with the flags
129                break
130            }
131        }
132    }
133
134    set dir [lindex $args $idx]
135    set patternList [lrange $args [expr {$idx + 1}] end]
136    if {[llength $patternList] == 0} {
137        set patternList [list "*.tcl" "*[info sharedlibextension]"]
138    }
139
140    set oldDir [pwd]
141    cd $dir
142
143    if {[catch {eval glob $patternList} fileList]} {
144        global errorCode errorInfo
145        cd $oldDir
146        return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList
147    }
148    foreach file $fileList {
149        # For each file, figure out what commands and packages it provides.
150        # To do this, create a child interpreter, load the file into the
151        # interpreter, and get a list of the new commands and packages
152        # that are defined.
153
154        if {[string equal $file "pkgIndex.tcl"]} {
155            continue
156        }
157
158        # Changed back to the original directory before initializing the
159        # slave in case TCL_LIBRARY is a relative path (e.g. in the test
160        # suite).
161
162        cd $oldDir
163        set c [interp create]
164
165        # Load into the child any packages currently loaded in the parent
166        # interpreter that match the -load pattern.
167
168        if {[string length $loadPat]} {
169            if {$doVerbose} {
170                tclLog "currently loaded packages: '[info loaded]'"
171                tclLog "trying to load all packages matching $loadPat"
172            }
173            if {![llength [info loaded]]} {
174                tclLog "warning: no packages are currently loaded, nothing"
175                tclLog "can possibly match '$loadPat'"
176            }
177        }
178        foreach pkg [info loaded] {
179            if {! [string match -nocase $loadPat [lindex $pkg 1]]} {
180                continue
181            }
182            if {$doVerbose} {
183                tclLog "package [lindex $pkg 1] matches '$loadPat'"
184            }
185            if {[catch {
186                load [lindex $pkg 0] [lindex $pkg 1] $c
187            } err]} {
188                if {$doVerbose} {
189                    tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
190                }
191            } elseif {$doVerbose} {
192                tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
193            }
194            if {[string equal [lindex $pkg 1] "Tk"]} {
195                # Withdraw . if Tk was loaded, to avoid showing a window.
196                $c eval [list wm withdraw .]
197            }
198        }
199        cd $dir
200
201        $c eval {
202            # Stub out the package command so packages can
203            # require other packages.
204
205            rename package __package_orig
206            proc package {what args} {
207                switch -- $what {
208                    require { return ; # ignore transitive requires }
209                    default { eval __package_orig {$what} $args }
210                }
211            }
212            proc tclPkgUnknown args {}
213            package unknown tclPkgUnknown
214
215            # Stub out the unknown command so package can call
216            # into each other during their initialilzation.
217
218            proc unknown {args} {}
219
220            # Stub out the auto_import mechanism
221
222            proc auto_import {args} {}
223
224            # reserve the ::tcl namespace for support procs
225            # and temporary variables.  This might make it awkward
226            # to generate a pkgIndex.tcl file for the ::tcl namespace.
227
228            namespace eval ::tcl {
229                variable file           ;# Current file being processed
230                variable direct         ;# -direct flag value
231                variable x              ;# Loop variable
232                variable debug          ;# For debugging
233                variable type           ;# "load" or "source", for -direct
234                variable namespaces     ;# Existing namespaces (e.g., ::tcl)
235                variable packages       ;# Existing packages (e.g., Tcl)
236                variable origCmds       ;# Existing commands
237                variable newCmds        ;# Newly created commands
238                variable newPkgs {}     ;# Newly created packages
239            }
240        }
241
242        $c eval [list set ::tcl::file $file]
243        $c eval [list set ::tcl::direct $direct]
244
245        # Download needed procedures into the slave because we've
246        # just deleted the unknown procedure.  This doesn't handle
247        # procedures with default arguments.
248
249        foreach p {pkg_compareExtension} {
250            $c eval [list proc $p [info args $p] [info body $p]]
251        }
252
253        if {[catch {
254            $c eval {
255                set ::tcl::debug "loading or sourcing"
256
257                # we need to track command defined by each package even in
258                # the -direct case, because they are needed internally by
259                # the "partial pkgIndex.tcl" step above.
260
261                proc ::tcl::GetAllNamespaces {{root ::}} {
262                    set list $root
263                    foreach ns [namespace children $root] {
264                        eval lappend list [::tcl::GetAllNamespaces $ns]
265                    }
266                    return $list
267                }
268
269                # init the list of existing namespaces, packages, commands
270
271                foreach ::tcl::x [::tcl::GetAllNamespaces] {
272                    set ::tcl::namespaces($::tcl::x) 1
273                }
274                foreach ::tcl::x [package names] {
275                    if {[string compare [package provide $::tcl::x] ""]} {
276                        set ::tcl::packages($::tcl::x) 1
277                    }
278                }
279                set ::tcl::origCmds [info commands]
280
281                # Try to load the file if it has the shared library
282                # extension, otherwise source it.  It's important not to
283                # try to load files that aren't shared libraries, because
284                # on some systems (like SunOS) the loader will abort the
285                # whole application when it gets an error.
286
287                if {[pkg_compareExtension $::tcl::file [info sharedlibextension]]} {
288                    # The "file join ." command below is necessary.
289                    # Without it, if the file name has no \'s and we're
290                    # on UNIX, the load command will invoke the
291                    # LD_LIBRARY_PATH search mechanism, which could cause
292                    # the wrong file to be used.
293
294                    set ::tcl::debug loading
295                    load [file join . $::tcl::file]
296                    set ::tcl::type load
297                } else {
298                    set ::tcl::debug sourcing
299                    source $::tcl::file
300                    set ::tcl::type source
301                }
302
303                # As a performance optimization, if we are creating
304                # direct load packages, don't bother figuring out the
305                # set of commands created by the new packages.  We
306                # only need that list for setting up the autoloading
307                # used in the non-direct case.
308                if { !$::tcl::direct } {
309                    # See what new namespaces appeared, and import commands
310                    # from them.  Only exported commands go into the index.
311                   
312                    foreach ::tcl::x [::tcl::GetAllNamespaces] {
313                        if {! [info exists ::tcl::namespaces($::tcl::x)]} {
314                            namespace import -force ${::tcl::x}::*
315                        }
316
317                        # Figure out what commands appeared
318                       
319                        foreach ::tcl::x [info commands] {
320                            set ::tcl::newCmds($::tcl::x) 1
321                        }
322                        foreach ::tcl::x $::tcl::origCmds {
323                            catch {unset ::tcl::newCmds($::tcl::x)}
324                        }
325                        foreach ::tcl::x [array names ::tcl::newCmds] {
326                            # determine which namespace a command comes from
327                           
328                            set ::tcl::abs [namespace origin $::tcl::x]
329                           
330                            # special case so that global names have no leading
331                            # ::, this is required by the unknown command
332                           
333                            set ::tcl::abs \
334                                    [lindex [auto_qualify $::tcl::abs ::] 0]
335                           
336                            if {[string compare $::tcl::x $::tcl::abs]} {
337                                # Name changed during qualification
338                               
339                                set ::tcl::newCmds($::tcl::abs) 1
340                                unset ::tcl::newCmds($::tcl::x)
341                            }
342                        }
343                    }
344                }
345
346                # Look through the packages that appeared, and if there is
347                # a version provided, then record it
348
349                foreach ::tcl::x [package names] {
350                    if {[string compare [package provide $::tcl::x] ""] \
351                            && ![info exists ::tcl::packages($::tcl::x)]} {
352                        lappend ::tcl::newPkgs \
353                            [list $::tcl::x [package provide $::tcl::x]]
354                    }
355                }
356            }
357        } msg] == 1} {
358            set what [$c eval set ::tcl::debug]
359            if {$doVerbose} {
360                tclLog "warning: error while $what $file: $msg"
361            }
362        } else {
363            set what [$c eval set ::tcl::debug]
364            if {$doVerbose} {
365                tclLog "successful $what of $file"
366            }
367            set type [$c eval set ::tcl::type]
368            set cmds [lsort [$c eval array names ::tcl::newCmds]]
369            set pkgs [$c eval set ::tcl::newPkgs]
370            if {$doVerbose} {
371                if { !$direct } {
372                    tclLog "commands provided were $cmds"
373                }
374                tclLog "packages provided were $pkgs"
375            }
376            if {[llength $pkgs] > 1} {
377                tclLog "warning: \"$file\" provides more than one package ($pkgs)"
378            }
379            foreach pkg $pkgs {
380                # cmds is empty/not used in the direct case
381                lappend files($pkg) [list $file $type $cmds]
382            }
383
384            if {$doVerbose} {
385                tclLog "processed $file"
386            }
387        }
388        interp delete $c
389    }
390
391    append index "# Tcl package index file, version 1.1\n"
392    append index "# This file is generated by the \"pkg_mkIndex$more\" command\n"
393    append index "# and sourced either when an application starts up or\n"
394    append index "# by a \"package unknown\" script.  It invokes the\n"
395    append index "# \"package ifneeded\" command to set up package-related\n"
396    append index "# information so that packages will be loaded automatically\n"
397    append index "# in response to \"package require\" commands.  When this\n"
398    append index "# script is sourced, the variable \$dir must contain the\n"
399    append index "# full path name of this file's directory.\n"
400
401    foreach pkg [lsort [array names files]] {
402        set cmd {}
403        foreach {name version} $pkg {
404            break
405        }
406        lappend cmd ::pkg::create -name $name -version $version
407        foreach spec $files($pkg) {
408            foreach {file type procs} $spec {
409                if { $direct } {
410                    set procs {}
411                }
412                lappend cmd "-$type" [list $file $procs]
413            }
414        }
415        append index "\n[eval $cmd]"
416    }
417
418    set f [open pkgIndex.tcl w]
419    puts $f $index
420    close $f
421    cd $oldDir
422}
423
424# tclPkgSetup --
425# This is a utility procedure use by pkgIndex.tcl files.  It is invoked
426# as part of a "package ifneeded" script.  It calls "package provide"
427# to indicate that a package is available, then sets entries in the
428# auto_index array so that the package's files will be auto-loaded when
429# the commands are used.
430#
431# Arguments:
432# dir -                 Directory containing all the files for this package.
433# pkg -                 Name of the package (no version number).
434# version -             Version number for the package, such as 2.1.3.
435# files -               List of files that constitute the package.  Each
436#                       element is a sub-list with three elements.  The first
437#                       is the name of a file relative to $dir, the second is
438#                       "load" or "source", indicating whether the file is a
439#                       loadable binary or a script to source, and the third
440#                       is a list of commands defined by this file.
441
442proc tclPkgSetup {dir pkg version files} {
443    global auto_index
444
445    package provide $pkg $version
446    foreach fileInfo $files {
447        set f [lindex $fileInfo 0]
448        set type [lindex $fileInfo 1]
449        foreach cmd [lindex $fileInfo 2] {
450            if {[string equal $type "load"]} {
451                set auto_index($cmd) [list load [file join $dir $f] $pkg]
452            } else {
453                set auto_index($cmd) [list source [file join $dir $f]]
454            } 
455        }
456    }
457}
458
459# tclPkgUnknown --
460# This procedure provides the default for the "package unknown" function.
461# It is invoked when a package that's needed can't be found.  It scans
462# the auto_path directories and their immediate children looking for
463# pkgIndex.tcl files and sources any such files that are found to setup
464# the package database.  (On the Macintosh we also search for pkgIndex
465# TEXT resources in all files.)  As it searches, it will recognize changes
466# to the auto_path and scan any new directories.
467#
468# Arguments:
469# name -                Name of desired package.  Not used.
470# version -             Version of desired package.  Not used.
471# exact -               Either "-exact" or omitted.  Not used.
472
473proc tclPkgUnknown {name version {exact {}}} {
474    global auto_path env
475
476    if {![info exists auto_path]} {
477        return
478    }
479    # Cache the auto_path, because it may change while we run through
480    # the first set of pkgIndex.tcl files
481    set old_path [set use_path $auto_path]
482    while {[llength $use_path]} {
483        set dir [lindex $use_path end]
484       
485        # Make sure we only scan each directory one time.
486        if {[info exists tclSeenPath($dir)]} {
487            set use_path [lrange $use_path 0 end-1]
488            continue
489        }
490        set tclSeenPath($dir) 1
491
492        # we can't use glob in safe interps, so enclose the following
493        # in a catch statement, where we get the pkgIndex files out
494        # of the subdirectories
495        catch {
496            foreach file [glob -directory $dir -join -nocomplain \
497                    * pkgIndex.tcl] {
498                set dir [file dirname $file]
499                if {![info exists procdDirs($dir)] && [file readable $file]} {
500                    if {[catch {source $file} msg]} {
501                        tclLog "error reading package index file $file: $msg"
502                    } else {
503                        set procdDirs($dir) 1
504                    }
505                }
506            }
507        }
508        set dir [lindex $use_path end]
509        if {![info exists procdDirs($dir)]} {
510            set file [file join $dir pkgIndex.tcl]
511            # safe interps usually don't have "file readable",
512            # nor stderr channel
513            if {([interp issafe] || [file readable $file])} {
514                if {[catch {source $file} msg] && ![interp issafe]}  {
515                    tclLog "error reading package index file $file: $msg"
516                } else {
517                    set procdDirs($dir) 1
518                }
519            }
520        }
521
522        set use_path [lrange $use_path 0 end-1]
523
524        # Check whether any of the index scripts we [source]d above
525        # set a new value for $::auto_path.  If so, then find any
526        # new directories on the $::auto_path, and lappend them to
527        # the $use_path we are working from.  This gives index scripts
528        # the (arguably unwise) power to expand the index script search
529        # path while the search is in progress.
530        set index 0
531        if {[llength $old_path] == [llength $auto_path]} {
532            foreach dir $auto_path old $old_path {
533                if {$dir ne $old} {
534                    # This entry in $::auto_path has changed.
535                    break
536                }
537                incr index
538            }
539        }
540
541        # $index now points to the first element of $auto_path that
542        # has changed, or the beginning if $auto_path has changed length
543        # Scan the new elements of $auto_path for directories to add to
544        # $use_path.  Don't add directories we've already seen, or ones
545        # already on the $use_path.
546        foreach dir [lrange $auto_path $index end] {
547            if {![info exists tclSeenPath($dir)] 
548                    && ([lsearch -exact $use_path $dir] == -1) } {
549                lappend use_path $dir
550            }
551        }
552        set old_path $auto_path
553    }
554}
555
556# tcl::MacOSXPkgUnknown --
557# This procedure extends the "package unknown" function for MacOSX.
558# It scans the Resources/Scripts directories of the immediate children
559# of the auto_path directories for pkgIndex files.
560# Only installed in interps that are not safe so we don't check
561# for [interp issafe] as in tclPkgUnknown.
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
569proc tcl::MacOSXPkgUnknown {original name version {exact {}}} {
570
571    #  First do the cross-platform default search
572    uplevel 1 $original [list $name $version $exact]
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        # get the pkgIndex files out of the subdirectories
586        foreach file [glob -directory $dir -join -nocomplain \
587                * Resources Scripts pkgIndex.tcl] {
588            set dir [file dirname $file]
589            if {[file readable $file] && ![info exists procdDirs($dir)]} {
590                if {[catch {source $file} msg]} {
591                    tclLog "error reading package index file $file: $msg"
592                } else {
593                    set procdDirs($dir) 1
594                }
595            }
596        }
597        set use_path [lrange $use_path 0 end-1]
598        if {[string compare $old_path $auto_path]} {
599            foreach dir $auto_path {
600                lappend use_path $dir
601            }
602            set old_path $auto_path
603        }
604    }
605}
606
607# tcl::MacPkgUnknown --
608# This procedure extends the "package unknown" function for Mac.
609# It searches for pkgIndex TEXT resources in all files
610# Only installed in interps that are not safe so we don't check
611# for [interp issafe] as in tclPkgUnknown.
612#
613# Arguments:
614# original -            original [package unknown] procedure
615# name -                Name of desired package.  Not used.
616# version -             Version of desired package.  Not used.
617# exact -               Either "-exact" or omitted.  Not used.
618
619proc tcl::MacPkgUnknown {original name version {exact {}}} {
620
621    #  First do the cross-platform default search
622    uplevel 1 $original [list $name $version $exact]
623
624    # Now do Mac specific searching
625    global auto_path
626
627    if {![info exists auto_path]} {
628        return
629    }
630    # Cache the auto_path, because it may change while we run through
631    # the first set of pkgIndex.tcl files
632    set old_path [set use_path $auto_path]
633    while {[llength $use_path]} {
634        # We look for pkgIndex TEXT resources in the resource fork of shared libraries
635        set dir [lindex $use_path end]
636        foreach x [concat [list $dir] [glob -directory $dir -nocomplain *] ] {
637            if {[file isdirectory $x] && ![info exists procdDirs($x)]} {
638                set dir $x
639                foreach x [glob -directory $dir -nocomplain *.shlb] {
640                    if {[file isfile $x]} {
641                        set res [resource open $x]
642                        foreach y [resource list TEXT $res] {
643                            if {[string equal $y "pkgIndex"]} {source -rsrc pkgIndex}
644                        }
645                        catch {resource close $res}
646                    }
647                }
648                set procdDirs($dir) 1
649            }
650        }
651        set use_path [lrange $use_path 0 end-1]
652        if {[string compare $old_path $auto_path]} {
653            foreach dir $auto_path {
654                lappend use_path $dir
655            }
656            set old_path $auto_path
657        }
658    }
659}
660
661# ::pkg::create --
662#
663#       Given a package specification generate a "package ifneeded" statement
664#       for the package, suitable for inclusion in a pkgIndex.tcl file.
665#
666# Arguments:
667#       args            arguments used by the create function:
668#                       -name           packageName
669#                       -version        packageVersion
670#                       -load           {filename ?{procs}?}
671#                       ...
672#                       -source         {filename ?{procs}?}
673#                       ...
674#
675#                       Any number of -load and -source parameters may be
676#                       specified, so long as there is at least one -load or
677#                       -source parameter.  If the procs component of a
678#                       module specifier is left off, that module will be
679#                       set up for direct loading; otherwise, it will be
680#                       set up for lazy loading.  If both -source and -load
681#                       are specified, the -load'ed files will be loaded
682#                       first, followed by the -source'd files.
683#
684# Results:
685#       An appropriate "package ifneeded" statement for the package.
686
687proc ::pkg::create {args} {
688    append err(usage) "[lindex [info level 0] 0] "
689    append err(usage) "-name packageName -version packageVersion"
690    append err(usage) "?-load {filename ?{procs}?}? ... "
691    append err(usage) "?-source {filename ?{procs}?}? ..."
692
693    set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\""
694    set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\""
695    set err(unknownOpt)   "unknown option \"%s\": should be \"$err(usage)\""
696    set err(noLoadOrSource) "at least one of -load and -source must be given"
697
698    # process arguments
699    set len [llength $args]
700    if { $len < 6 } {
701        error $err(wrongNumArgs)
702    }
703   
704    # Initialize parameters
705    set opts(-name)             {}
706    set opts(-version)          {}
707    set opts(-source)           {}
708    set opts(-load)             {}
709
710    # process parameters
711    for {set i 0} {$i < $len} {incr i} {
712        set flag [lindex $args $i]
713        incr i
714        switch -glob -- $flag {
715            "-name"             -
716            "-version"          {
717                if { $i >= $len } {
718                    error [format $err(valueMissing) $flag]
719                }
720                set opts($flag) [lindex $args $i]
721            }
722            "-source"           -
723            "-load"             {
724                if { $i >= $len } {
725                    error [format $err(valueMissing) $flag]
726                }
727                lappend opts($flag) [lindex $args $i]
728            }
729            default {
730                error [format $err(unknownOpt) [lindex $args $i]]
731            }
732        }
733    }
734
735    # Validate the parameters
736    if { [llength $opts(-name)] == 0 } {
737        error [format $err(valueMissing) "-name"]
738    }
739    if { [llength $opts(-version)] == 0 } {
740        error [format $err(valueMissing) "-version"]
741    }
742   
743    if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {
744        error $err(noLoadOrSource)
745    }
746
747    # OK, now everything is good.  Generate the package ifneeded statment.
748    set cmdline "package ifneeded $opts(-name) $opts(-version) "
749   
750    set cmdList {}
751    set lazyFileList {}
752
753    # Handle -load and -source specs
754    foreach key {load source} {
755        foreach filespec $opts(-$key) {
756            foreach {filename proclist} {{} {}} {
757                break
758            }
759            foreach {filename proclist} $filespec {
760                break
761            }
762           
763            if { [llength $proclist] == 0 } {
764                set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
765                lappend cmdList $cmd
766            } else {
767                lappend lazyFileList [list $filename $key $proclist]
768            }
769        }
770    }
771
772    if { [llength $lazyFileList] > 0 } {
773        lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
774                $opts(-version) [list $lazyFileList]\]"
775    }
776    append cmdline [join $cmdList "\\n"]
777    return $cmdline
778}
779
Note: See TracBrowser for help on using the repository browser.