diff options
Diffstat (limited to 'library/init.tcl')
| -rw-r--r-- | library/init.tcl | 78 |
1 files changed, 69 insertions, 9 deletions
diff --git a/library/init.tcl b/library/init.tcl index 58350e8..71c0b78 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -3,7 +3,7 @@ # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # -# RCS: @(#) $Id: init.tcl,v 1.15 1998/09/14 18:40:03 stanton Exp $ +# RCS: @(#) $Id: init.tcl,v 1.16 1998/10/17 00:15:40 escoffon Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -1043,6 +1043,46 @@ tcl_nonsafe auto_mkindex_parser::command namespace {op args} { rename tcl_nonsafe "" +# pkg_compareExtension -- +# +# Used internally by pkg_mkIndex to compare the extension of a file to +# a given extension. On Windows, it uses a case-insensitive comparison +# because the file system can be file insensitive. +# +# Arguments: +# fileName name of a file whose extension is compared +# ext (optional) The extension to compare against; you must +# provide the starting dot. +# Defaults to [info sharedlibextension] +# +# Results: +# Returns 1 if the extension matches, 0 otherwise + +if {$::tcl_platform(platform) == "windows"} { + proc pkg_compareExtension { fileName {ext {}} } { + if {[string compare $ext {}] == 0} { + set ext [info sharedlibextension] + } + set cmp [string compare \ + [string tolower [file extension $fileName]] \ + [string tolower $ext]] + if {$cmp} { + return 0 + } + return 1 + } +} else { + proc pkg_compareExtension { fileName {ext {}} } { + if {[string compare $ext {}] == 0} { + set ext [info sharedlibextension] + } + if {[string compare [file extension $fileName] $ext]} { + return 0 + } + return 1 + } +} + # pkg_mkIndex -- # This procedure creates a package index in a given directory. The # package index consists of a "pkgIndex.tcl" file whose contents are @@ -1144,8 +1184,15 @@ proc pkg_mkIndex {args} { # repeated passes on the files to index, until either all have been # indexed, or we can no longer make any headway. - foreach file [eval glob $patternList] { - set toProcess($file) 1 + if {[catch { + foreach file [eval glob $patternList] { + set toProcess($file) 1 + } + } err]} { + set ei $::errorInfo + set ec $::errorCode + cd $oldDir + error $err $ei $ec } while {[array size toProcess] > 0} { @@ -1177,11 +1224,13 @@ proc pkg_mkIndex {args} { # identified so far. This way, each pass will have loaded the # equivalent of the pkgIndex.tcl file that we are constructing, # and packages whose processing failed in previous passes may - # be processed successfully now + # be processed successfully now. + # Note that the $dir value is hardwired to ".", because we are + # in the directory with the .tcl files. foreach pkg [array names files] { $c eval "package ifneeded $pkg\ - \[list tclPkgSetup $dir \ + \[list tclPkgSetup . \ [lrange $pkg 0 0] [lrange $pkg 1 1]\ [list $files($pkg)]\]" } @@ -1223,7 +1272,7 @@ proc pkg_mkIndex {args} { # packages that are spread over multiple # files are indexed only by their first file # loaded. - # Note that packages that this cannot catch + # Note that that this cannot detect # packages that are implemented by a # combination of TCL files and DLLs @@ -1241,6 +1290,10 @@ proc pkg_mkIndex {args} { } } + # make sure that the auto_path in the slave is consistent + # with ours + $c eval [list set auto_path $::auto_path] + $c eval [list set __file $file] $c eval [list set __direct $direct] if {[catch { @@ -1352,9 +1405,7 @@ proc pkg_mkIndex {args} { set __pkgs {} set __providedPkgs {} - if {[string compare [file extension $__file] \ - [info sharedlibextension]] == 0} { - + if {[pkg_compareExtension $__file [info sharedlibextension]]} { # The "file join ." command below is necessary. # Without it, if the file name has no \'s and we're # on UNIX, the load command will invoke the @@ -1399,6 +1450,15 @@ proc pkg_mkIndex {args} { set __cmds($__absolute) 1 unset __cmds($__i) } + + # final check, to support packages spread over + # multiple files: if the new command is in the + # namespace of an ignored package, de-ignore it. + + regsub {^::} [namespace qualifiers $__absolute] {} __qual + if {[info exists ::__ignorePkgs($__qual)]} { + unset ::__ignorePkgs($__qual) + } } foreach __i $::__providedPkgs { |