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