os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/library/package.tcl
author sl
Tue, 10 Jun 2014 14:32:02 +0200 (2014-06-10)
changeset 1 260cb5ec6c19
permissions -rw-r--r--
Update contrib.
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