Tcl Source Code

Artifact 4f62440bc39f4a8bf58e78f7d1004efb13114948:

Attachment "packages_cache.tcl" to ticket [3523089fff] added by basilik99 2012-05-03 00:57:17.

---

proc tcl::PackageIndexCache { original name version {exact {}} } {
    global env
    variable PackageIndexCache
    unset -nocomplain PackageIndexCache
    array set PackageIndexCache {}

    foreach dir [list [info library] $env(APPDATA)] {
        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
                }
            }
            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, search in next cache file (or do full search)
                if {![info exists testversion]} {continue}
            }
            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
            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

    # 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

    # Combine gathered data with other 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] $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]]