Context Navigation

package.tcl @ 5241

Last change on this file since 5241 was 5167, checked in by rgrieder, 16 years ago
added svn property svn:eol-style native to all tcl files
Property svn:eol-style set to `native`
File size: 24.6 KB

Line
1	# package.tcl --
2	#
3	# utility procs formerly in init.tcl which can be loaded on demand
4	# for package management.
5	#
6	# RCS: @(#) $Id: package.tcl,v 1.23.2.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
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 {$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
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 [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
443	proc 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
475	proc 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
579	if {[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
668	proc 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
736	proc ::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.

Context Navigation

source: data/media/tcl8.4/package.tcl @ 5241

Download in other formats: