Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: data/trunk/Media/tcl8.4/package.tcl @ 5292

Last change on this file since 5292 was 5180, checked in by dafrick, 16 years ago
File size: 24.6 KB
RevLine 
[5180]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.4 2006/09/22 01:26:24 andreas_kupries 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 {$ext eq ""} {set ext [info sharedlibextension]}
37    if {$tcl_platform(platform) eq "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 {$currExt eq $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 [linsert $patternList 0 glob --]} 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 {$file eq "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 {$loadPat ne ""} {
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 {[lindex $pkg 1] eq "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 { uplevel 1 [linsert $args 0 __package_orig $what] }
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 [linsert [::tcl::GetAllNamespaces $ns] 0 \
265                                lappend list]
266                    }
267                    return $list
268                }
269
270                # init the list of existing namespaces, packages, commands
271
272                foreach ::tcl::x [::tcl::GetAllNamespaces] {
273                    set ::tcl::namespaces($::tcl::x) 1
274                }
275                foreach ::tcl::x [package names] {
276                    if {[package provide $::tcl::x] ne ""} {
277                        set ::tcl::packages($::tcl::x) 1
278                    }
279                }
280                set ::tcl::origCmds [info commands]
281
282                # Try to load the file if it has the shared library
283                # extension, otherwise source it.  It's important not to
284                # try to load files that aren't shared libraries, because
285                # on some systems (like SunOS) the loader will abort the
286                # whole application when it gets an error.
287
288                if {[pkg_compareExtension $::tcl::file [info sharedlibextension]]} {
289                    # The "file join ." command below is necessary.
290                    # Without it, if the file name has no \'s and we're
291                    # on UNIX, the load command will invoke the
292                    # LD_LIBRARY_PATH search mechanism, which could cause
293                    # the wrong file to be used.
294
295                    set ::tcl::debug loading
296                    load [file join . $::tcl::file]
297                    set ::tcl::type load
298                } else {
299                    set ::tcl::debug sourcing
300                    source $::tcl::file
301                    set ::tcl::type source
302                }
303
304                # As a performance optimization, if we are creating
305                # direct load packages, don't bother figuring out the
306                # set of commands created by the new packages.  We
307                # only need that list for setting up the autoloading
308                # used in the non-direct case.
309                if { !$::tcl::direct } {
310                    # See what new namespaces appeared, and import commands
311                    # from them.  Only exported commands go into the index.
312                   
313                    foreach ::tcl::x [::tcl::GetAllNamespaces] {
314                        if {! [info exists ::tcl::namespaces($::tcl::x)]} {
315                            namespace import -force ${::tcl::x}::*
316                        }
317
318                        # Figure out what commands appeared
319                       
320                        foreach ::tcl::x [info commands] {
321                            set ::tcl::newCmds($::tcl::x) 1
322                        }
323                        foreach ::tcl::x $::tcl::origCmds {
324                            unset -nocomplain ::tcl::newCmds($::tcl::x)
325                        }
326                        foreach ::tcl::x [array names ::tcl::newCmds] {
327                            # determine which namespace a command comes from
328                           
329                            set ::tcl::abs [namespace origin $::tcl::x]
330                           
331                            # special case so that global names have no leading
332                            # ::, this is required by the unknown command
333                           
334                            set ::tcl::abs \
335                                    [lindex [auto_qualify $::tcl::abs ::] 0]
336                           
337                            if {$::tcl::x ne $::tcl::abs} {
338                                # Name changed during qualification
339                               
340                                set ::tcl::newCmds($::tcl::abs) 1
341                                unset ::tcl::newCmds($::tcl::x)
342                            }
343                        }
344                    }
345                }
346
347                # Look through the packages that appeared, and if there is
348                # a version provided, then record it
349
350                foreach ::tcl::x [package names] {
351                    if {[package provide $::tcl::x] ne ""
352                            && ![info exists ::tcl::packages($::tcl::x)]} {
353                        lappend ::tcl::newPkgs \
354                            [list $::tcl::x [package provide $::tcl::x]]
355                    }
356                }
357            }
358        } msg] == 1} {
359            set what [$c eval set ::tcl::debug]
360            if {$doVerbose} {
361                tclLog "warning: error while $what $file: $msg"
362            }
363        } else {
364            set what [$c eval set ::tcl::debug]
365            if {$doVerbose} {
366                tclLog "successful $what of $file"
367            }
368            set type [$c eval set ::tcl::type]
369            set cmds [lsort [$c eval array names ::tcl::newCmds]]
370            set pkgs [$c eval set ::tcl::newPkgs]
371            if {$doVerbose} {
372                if { !$direct } {
373                    tclLog "commands provided were $cmds"
374                }
375                tclLog "packages provided were $pkgs"
376            }
377            if {[llength $pkgs] > 1} {
378                tclLog "warning: \"$file\" provides more than one package ($pkgs)"
379            }
380            foreach pkg $pkgs {
381                # cmds is empty/not used in the direct case
382                lappend files($pkg) [list $file $type $cmds]
383            }
384
385            if {$doVerbose} {
386                tclLog "processed $file"
387            }
388        }
389        interp delete $c
390    }
391
392    append index "# Tcl package index file, version 1.1\n"
393    append index "# This file is generated by the \"pkg_mkIndex$more\" command\n"
394    append index "# and sourced either when an application starts up or\n"
395    append index "# by a \"package unknown\" script.  It invokes the\n"
396    append index "# \"package ifneeded\" command to set up package-related\n"
397    append index "# information so that packages will be loaded automatically\n"
398    append index "# in response to \"package require\" commands.  When this\n"
399    append index "# script is sourced, the variable \$dir must contain the\n"
400    append index "# full path name of this file's directory.\n"
401
402    foreach pkg [lsort [array names files]] {
403        set cmd {}
404        foreach {name version} $pkg {
405            break
406        }
407        lappend cmd ::pkg::create -name $name -version $version
408        foreach spec $files($pkg) {
409            foreach {file type procs} $spec {
410                if { $direct } {
411                    set procs {}
412                }
413                lappend cmd "-$type" [list $file $procs]
414            }
415        }
416        append index "\n[eval $cmd]"
417    }
418
419    set f [open pkgIndex.tcl w]
420    puts $f $index
421    close $f
422    cd $oldDir
423}
424
425# tclPkgSetup --
426# This is a utility procedure use by pkgIndex.tcl files.  It is invoked
427# as part of a "package ifneeded" script.  It calls "package provide"
428# to indicate that a package is available, then sets entries in the
429# auto_index array so that the package's files will be auto-loaded when
430# the commands are used.
431#
432# Arguments:
433# dir -                 Directory containing all the files for this package.
434# pkg -                 Name of the package (no version number).
435# version -             Version number for the package, such as 2.1.3.
436# files -               List of files that constitute the package.  Each
437#                       element is a sub-list with three elements.  The first
438#                       is the name of a file relative to $dir, the second is
439#                       "load" or "source", indicating whether the file is a
440#                       loadable binary or a script to source, and the third
441#                       is a list of commands defined by this file.
442
443proc tclPkgSetup {dir pkg version files} {
444    global auto_index
445
446    package provide $pkg $version
447    foreach fileInfo $files {
448        set f [lindex $fileInfo 0]
449        set type [lindex $fileInfo 1]
450        foreach cmd [lindex $fileInfo 2] {
451            if {$type eq "load"} {
452                set auto_index($cmd) [list load [file join $dir $f] $pkg]
453            } else {
454                set auto_index($cmd) [list source [file join $dir $f]]
455            } 
456        }
457    }
458}
459
460# tclPkgUnknown --
461# This procedure provides the default for the "package unknown" function.
462# It is invoked when a package that's needed can't be found.  It scans
463# the auto_path directories and their immediate children looking for
464# pkgIndex.tcl files and sources any such files that are found to setup
465# the package database.  (On the Macintosh we also search for pkgIndex
466# TEXT resources in all files.)  As it searches, it will recognize changes
467# to the auto_path and scan any new directories.
468#
469# Arguments:
470# name -                Name of desired package.  Not used.
471# version -             Version of desired package.  Not used.
472# exact -               Either "-exact" or omitted.  Not used.
473
474
475proc tclPkgUnknown [expr {
476                          [info exists tcl_platform(tip,268)]
477                          ? "name args"
478                          : "name version {exact {}}"
479                      }] {
480    global auto_path env
481
482    if {![info exists auto_path]} {
483        return
484    }
485    # Cache the auto_path, because it may change while we run through
486    # the first set of pkgIndex.tcl files
487    set old_path [set use_path $auto_path]
488    while {[llength $use_path]} {
489        set dir [lindex $use_path end]
490       
491        # Make sure we only scan each directory one time.
492        if {[info exists tclSeenPath($dir)]} {
493            set use_path [lrange $use_path 0 end-1]
494            continue
495        }
496        set tclSeenPath($dir) 1
497
498        # we can't use glob in safe interps, so enclose the following
499        # in a catch statement, where we get the pkgIndex files out
500        # of the subdirectories
501        catch {
502            foreach file [glob -directory $dir -join -nocomplain \
503                    * pkgIndex.tcl] {
504                set dir [file dirname $file]
505                if {![info exists procdDirs($dir)] && [file readable $file]} {
506                    if {[catch {source $file} msg]} {
507                        tclLog "error reading package index file $file: $msg"
508                    } else {
509                        set procdDirs($dir) 1
510                    }
511                }
512            }
513        }
514        set dir [lindex $use_path end]
515        if {![info exists procdDirs($dir)]} {
516            set file [file join $dir pkgIndex.tcl]
517            # safe interps usually don't have "file readable",
518            # nor stderr channel
519            if {([interp issafe] || [file readable $file])} {
520                if {[catch {source $file} msg] && ![interp issafe]}  {
521                    tclLog "error reading package index file $file: $msg"
522                } else {
523                    set procdDirs($dir) 1
524                }
525            }
526        }
527
528        set use_path [lrange $use_path 0 end-1]
529
530        # Check whether any of the index scripts we [source]d above
531        # set a new value for $::auto_path.  If so, then find any
532        # new directories on the $::auto_path, and lappend them to
533        # the $use_path we are working from.  This gives index scripts
534        # the (arguably unwise) power to expand the index script search
535        # path while the search is in progress.
536        set index 0
537        if {[llength $old_path] == [llength $auto_path]} {
538            foreach dir $auto_path old $old_path {
539                if {$dir ne $old} {
540                    # This entry in $::auto_path has changed.
541                    break
542                }
543                incr index
544            }
545        }
546
547        # $index now points to the first element of $auto_path that
548        # has changed, or the beginning if $auto_path has changed length
549        # Scan the new elements of $auto_path for directories to add to
550        # $use_path.  Don't add directories we've already seen, or ones
551        # already on the $use_path.
552        foreach dir [lrange $auto_path $index end] {
553            if {![info exists tclSeenPath($dir)] 
554                    && ([lsearch -exact $use_path $dir] == -1) } {
555                lappend use_path $dir
556            }
557        }
558        set old_path $auto_path
559    }
560}
561
562# tcl::MacOSXPkgUnknown --
563# This procedure extends the "package unknown" function for MacOSX.
564# It scans the Resources/Scripts directories of the immediate children
565# of the auto_path directories for pkgIndex files.
566# Only installed in interps that are not safe so we don't check
567# for [interp issafe] as in tclPkgUnknown.
568#
569# Arguments:
570# original -            original [package unknown] procedure
571# name -                Name of desired package.  Not used.
572#ifndef TCL_TIP268
573# version -             Version of desired package.  Not used.
574# exact -               Either "-exact" or omitted.  Not used.
575#else
576# args -                List of requirements. Not used.
577#endif
578
579if {[info exists tcl_platform(tip,268)]} {
580    proc tcl::MacOSXPkgUnknown {original name args} {
581        #  First do the cross-platform default search
582        uplevel 1 $original [linsert $args 0 $name]
583
584        # Now do MacOSX specific searching
585        global auto_path
586
587        if {![info exists auto_path]} {
588            return
589        }
590        # Cache the auto_path, because it may change while we run through
591        # the first set of pkgIndex.tcl files
592        set old_path [set use_path $auto_path]
593        while {[llength $use_path]} {
594            set dir [lindex $use_path end]
595            # get the pkgIndex files out of the subdirectories
596            foreach file [glob -directory $dir -join -nocomplain \
597                              * Resources Scripts pkgIndex.tcl] {
598                set dir [file dirname $file]
599                if {[file readable $file] && ![info exists procdDirs($dir)]} {
600                    if {[catch {source $file} msg]} {
601                        tclLog "error reading package index file $file: $msg"
602                    } else {
603                        set procdDirs($dir) 1
604                    }
605                }
606            }
607            set use_path [lrange $use_path 0 end-1]
608            if {$old_path ne $auto_path} {
609                foreach dir $auto_path {
610                    lappend use_path $dir
611                }
612                set old_path $auto_path
613            }
614        }
615    }
616} else {
617    proc tcl::MacOSXPkgUnknown {original name version {exact {}}} {
618
619        #  First do the cross-platform default search
620        uplevel 1 $original [list $name $version $exact]
621
622        # Now do MacOSX specific searching
623        global auto_path
624
625        if {![info exists auto_path]} {
626            return
627        }
628        # Cache the auto_path, because it may change while we run through
629        # the first set of pkgIndex.tcl files
630        set old_path [set use_path $auto_path]
631        while {[llength $use_path]} {
632            set dir [lindex $use_path end]
633            # get the pkgIndex files out of the subdirectories
634            foreach file [glob -directory $dir -join -nocomplain \
635                              * Resources Scripts pkgIndex.tcl] {
636                set dir [file dirname $file]
637                if {[file readable $file] && ![info exists procdDirs($dir)]} {
638                    if {[catch {source $file} msg]} {
639                        tclLog "error reading package index file $file: $msg"
640                    } else {
641                        set procdDirs($dir) 1
642                    }
643                }
644            }
645            set use_path [lrange $use_path 0 end-1]
646            if {$old_path ne $auto_path} {
647                foreach dir $auto_path {
648                    lappend use_path $dir
649                }
650                set old_path $auto_path
651            }
652        }
653    }
654}
655
656# tcl::MacPkgUnknown --
657# This procedure extends the "package unknown" function for Mac.
658# It searches for pkgIndex TEXT resources in all files
659# Only installed in interps that are not safe so we don't check
660# for [interp issafe] as in tclPkgUnknown.
661#
662# Arguments:
663# original -            original [package unknown] procedure
664# name -                Name of desired package.  Not used.
665# version -             Version of desired package.  Not used.
666# exact -               Either "-exact" or omitted.  Not used.
667
668proc tcl::MacPkgUnknown {original name version {exact {}}} {
669
670    #  First do the cross-platform default search
671    uplevel 1 $original [list $name $version $exact]
672
673    # Now do Mac specific searching
674    global auto_path
675
676    if {![info exists auto_path]} {
677        return
678    }
679    # Cache the auto_path, because it may change while we run through
680    # the first set of pkgIndex.tcl files
681    set old_path [set use_path $auto_path]
682    while {[llength $use_path]} {
683        # We look for pkgIndex TEXT resources in the resource fork of shared libraries
684        set dir [lindex $use_path end]
685        foreach x [concat [list $dir] [glob -directory $dir -nocomplain *] ] {
686            if {[file isdirectory $x] && ![info exists procdDirs($x)]} {
687                set dir $x
688                foreach x [glob -directory $dir -nocomplain *.shlb] {
689                    if {[file isfile $x]} {
690                        set res [resource open $x]
691                        foreach y [resource list TEXT $res] {
692                            if {$y eq "pkgIndex"} {source -rsrc pkgIndex}
693                        }
694                        catch {resource close $res}
695                    }
696                }
697                set procdDirs($dir) 1
698            }
699        }
700        set use_path [lrange $use_path 0 end-1]
701        if {$old_path ne $auto_path} {
702            foreach dir $auto_path {
703                lappend use_path $dir
704            }
705            set old_path $auto_path
706        }
707    }
708}
709
710# ::pkg::create --
711#
712#       Given a package specification generate a "package ifneeded" statement
713#       for the package, suitable for inclusion in a pkgIndex.tcl file.
714#
715# Arguments:
716#       args            arguments used by the create function:
717#                       -name           packageName
718#                       -version        packageVersion
719#                       -load           {filename ?{procs}?}
720#                       ...
721#                       -source         {filename ?{procs}?}
722#                       ...
723#
724#                       Any number of -load and -source parameters may be
725#                       specified, so long as there is at least one -load or
726#                       -source parameter.  If the procs component of a
727#                       module specifier is left off, that module will be
728#                       set up for direct loading; otherwise, it will be
729#                       set up for lazy loading.  If both -source and -load
730#                       are specified, the -load'ed files will be loaded
731#                       first, followed by the -source'd files.
732#
733# Results:
734#       An appropriate "package ifneeded" statement for the package.
735
736proc ::pkg::create {args} {
737    append err(usage) "[lindex [info level 0] 0] "
738    append err(usage) "-name packageName -version packageVersion"
739    append err(usage) "?-load {filename ?{procs}?}? ... "
740    append err(usage) "?-source {filename ?{procs}?}? ..."
741
742    set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\""
743    set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\""
744    set err(unknownOpt)   "unknown option \"%s\": should be \"$err(usage)\""
745    set err(noLoadOrSource) "at least one of -load and -source must be given"
746
747    # process arguments
748    set len [llength $args]
749    if { $len < 6 } {
750        error $err(wrongNumArgs)
751    }
752   
753    # Initialize parameters
754    set opts(-name)             {}
755    set opts(-version)          {}
756    set opts(-source)           {}
757    set opts(-load)             {}
758
759    # process parameters
760    for {set i 0} {$i < $len} {incr i} {
761        set flag [lindex $args $i]
762        incr i
763        switch -glob -- $flag {
764            "-name"             -
765            "-version"          {
766                if { $i >= $len } {
767                    error [format $err(valueMissing) $flag]
768                }
769                set opts($flag) [lindex $args $i]
770            }
771            "-source"           -
772            "-load"             {
773                if { $i >= $len } {
774                    error [format $err(valueMissing) $flag]
775                }
776                lappend opts($flag) [lindex $args $i]
777            }
778            default {
779                error [format $err(unknownOpt) [lindex $args $i]]
780            }
781        }
782    }
783
784    # Validate the parameters
785    if { [llength $opts(-name)] == 0 } {
786        error [format $err(valueMissing) "-name"]
787    }
788    if { [llength $opts(-version)] == 0 } {
789        error [format $err(valueMissing) "-version"]
790    }
791   
792    if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {
793        error $err(noLoadOrSource)
794    }
795
796    # OK, now everything is good.  Generate the package ifneeded statment.
797    set cmdline "package ifneeded $opts(-name) $opts(-version) "
798   
799    set cmdList {}
800    set lazyFileList {}
801
802    # Handle -load and -source specs
803    foreach key {load source} {
804        foreach filespec $opts(-$key) {
805            foreach {filename proclist} {{} {}} {
806                break
807            }
808            foreach {filename proclist} $filespec {
809                break
810            }
811           
812            if { [llength $proclist] == 0 } {
813                set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
814                lappend cmdList $cmd
815            } else {
816                lappend lazyFileList [list $filename $key $proclist]
817            }
818        }
819    }
820
821    if { [llength $lazyFileList] > 0 } {
822        lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
823                $opts(-version) [list $lazyFileList]\]"
824    }
825    append cmdline [join $cmdList "\\n"]
826    return $cmdline
827}
828
Note: See TracBrowser for help on using the repository browser.