Commit | Line | Data |
---|---|---|
920dae64 AT |
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 | |
16 | namespace 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 | ||
34 | proc 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 | ||
88 | proc 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 | ||
442 | proc 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 | ||
473 | proc 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 | ||
569 | proc 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 | ||
619 | proc 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 | ||
687 | proc ::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 |