Attachment "indexCache.patch" to
ticket [680169ffff]
added by
dgp
2003-03-05 00:30:41.
Index: library/init.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/init.tcl,v
retrieving revision 1.55
diff -u -r1.55 init.tcl
--- library/init.tcl 23 Nov 2002 01:41:35 -0000 1.55
+++ library/init.tcl 4 Mar 2003 17:08:12 -0000
@@ -724,3 +724,113 @@
}
return
}
+
+proc tcl::PackageIndexCache { original name version {exact {}} } {
+ variable PackageIndexCache
+ unset -nocomplain PackageIndexCache
+ array set PackageIndexCache {}
+
+ foreach dir [list [info library] ~] {
+ set file [file join $dir .tclPackageIndexCache]
+ if {[file readable $file]} {
+ catch {source $file}
+
+ # As soon as we've satisfied the package requirement
+ # using the cache, we're done. Test for that.
+ if {$version eq ""} {
+ if {[llength [package versions $name]]} {
+ # Our work is done
+ unset PackageIndexCache
+ return
+ } else {
+ continue
+ }
+ }
+ set testversion $version
+ if {$exact ne "-exact"} {
+ foreach v [package versions $name] {
+ if {[package vsatisfies $v $version]} {
+ set testversion $v
+ break
+ }
+ }
+ }
+ if {[package ifneeded $name $testversion] ne ""} {
+ # Our work is done
+ unset PackageIndexCache
+ return
+ }
+ }
+ }
+
+ # Wrap Tcl's built-in [package] command so we can intercept and
+ # record all [package ifneeded] calls.
+ rename ::package ::tcl::Package
+
+ variable PackageIndex
+ unset -nocomplain PackageIndex
+ array set PackageIndex {}
+ proc ::package {sub args} {
+ if {[string match i* $sub] && ([string first $sub ifneeded] == 0)} {
+ variable ::tcl::PackageIndex
+ foreach {name version script} $args {break}
+ while {[regsub {[.]0+$} $version {} version]} {}
+ set PackageIndex([list $name $version]) $script
+ }
+ uplevel 1 [lreplace [info level 0] 0 0 ::tcl::Package]
+ }
+
+ set original_auto_path $::auto_path
+
+ # Let the original [package unknown] seek and eval index scripts
+ set code [catch {
+ uplevel 1 $original [list $name $version $exact]
+ } result]
+
+ # Restore the original [::package]
+ rename ::package {}
+ rename ::tcl::Package ::package
+
+ # Save a record of the [package ifneeded] calls in a cache file.
+ # Let every different [info hostname], [info nameofexecutable],
+ # and $::auto_path determine a different cache.
+
+ set script ""
+ foreach {pair value} [array get PackageIndex] {
+ foreach {p v} $pair {break}
+ append script "[list package ifneeded $p $v $value]\n"
+ }
+ if {$::auto_path ne $original_auto_path} {
+ append script "[list set ::auto_path $::auto_path]\n"
+ }
+ unset PackageIndex
+
+ # Combine gathered data with othe data from previous cache
+ set PackageIndexCache([list [info hostname] [info nameofexecutable] \
+ $original_auto_path]) $script
+ set contents \
+ [list array set PackageIndexCache [array get PackageIndexCache]]
+ append contents {
+ eval $PackageIndexCache([list [info hostname] [info nameofexecutable] \
+ $::auto_path])
+ }
+ unset PackageIndexCache
+
+ # Try to save cache in $tcl_library for everyone's benefit.
+ # If permissions are lacking, at least save it for yourself.
+
+ foreach dir [list [info library] ~] {
+ set file [file join $dir .tclPackageIndexCache]
+ if {[file writable $dir]} {
+ set f [open $file.[pid] w]
+ puts $f $contents
+ close $f
+ file rename -force $file.[pid] $file
+ }
+ }
+
+ return -code $code $result
+}
+
+package unknown [list tcl::PackageIndexCache [package unknown]]
+
