Tcl Source Code

Artifact c3290099eea6f2f1501a7ec0db2baffae7052846:

Attachment "packages_cache_improved.tcl" to ticket [3523089fff] added by basilik99 2012-05-15 03:24:28.

---

proc tcl::PackageIndexCache { original name version {exact {}} } {
   global env
   variable PackageIndexCache
   variable PackageIndexCache_auto_path
   
   # Avoid the cost of loading PackageIndexCache file each time a package is not found. Indeed, the cache will not help in these cases, except for
   # the first cache loading and when auto_path changes (in which case a new key of the cache will get loaded).
   if {(![info exists PackageIndexCache]) || (![info exists PackageIndexCache_auto_path]) || ($PackageIndexCache_auto_path ne $::auto_path)} \
   {
      array set PackageIndexCache {}

      set dir $env(APPDATA)
      set file [file join $dir .tclPackageIndexCache]
      if {[file readable $file]} {
         set PackageIndexCache_auto_path $::auto_path
         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
               return
            } ;# else: directly go to the package search below
         } \
         else \
         {
            if {$exact ne "-exact"} {
               foreach v [package versions $name] {
                  if {[package vsatisfies $v $version]} {
                     set testversion $v
                     break
                  }
               }
            }
            # If no version satisfies the required version, do full search
            if {[info exists testversion]} \
            {
               if {[package ifneeded $name $testversion] ne ""} {
                  # Our work is done
                  return
               }
            }
         }
      }
   }
   
   set packages_known_initially {}
   foreach p [package names] \
   {
      lappend packages_known_initially "$p [package versions $p]"
   }
   
   # 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
         lassign $args name version script
         # Avoid logging cases where [package ifneeded] is called without a script (but to retrieve that script)
         if {$script ne ""} \
         {
            while {[regsub {[.]0+$} $version {} version]} {}
            # If the "package ifneeded" was invoked directly in a pkgIndex.tcl file
            set ifneeded_script [uplevel 1 {info script}]
            if {[file tail $ifneeded_script] eq "pkgIndex.tcl"} \
            {
               # Then source the whole pkgIndex.tcl file when the package will be needed rather than only executing $script
               set PackageIndex([list $name $version]) "apply {{} {
                  set dir [uplevel 1 {set dir}];
                  source $ifneeded_script;
                  eval \[package ifneeded $name $version\]
                  }}"
            } \
            else \
            {
               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
   
   set packages_known_now {}
   foreach p [package names] \
   {
      lappend packages_known_now "$p [package versions $p]"
   }
   
   # If the content of the keys of the cache havn't changed, don't rewrite the cache file uselessly
   if {($packages_known_now != $packages_known_initially) || ($::auto_path ne $original_auto_path)} \
   {
      # 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] {
         lassign $pair p v
         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

      if {[info exists PackageIndexCache([list [info hostname] [info nameofexecutable] $original_auto_path])]} \
      {
         # Combine gathered data with other data from previous cache (this is possible when auto_path is identical, but new packages are known now)
         append PackageIndexCache([list [info hostname] [info nameofexecutable] $original_auto_path]) $script
      } else {
         # Set that key for the first time
         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])
      }

      # Save the cache in current user's directory (if writable)
      set dir $env(APPDATA)
      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]]