source: proiecte/pmake3d/make3d_original/Make3dSingleImageStanford_version0.1/third_party/vrippack-0.31/src/vrip/lib/tcl/package.tcl @ 37

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

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