You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2166 lines
110 KiB
2166 lines
110 KiB
# -*- tcl -*- |
|
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2025 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::libunknown 0.2.2 |
|
# Meta platform tcl |
|
# Meta license MIT |
|
# @@ Meta End |
|
# |
|
# Version history (manually versioned module - the real version lives in the |
|
# filename and the 'package provide' block at the bottom; there is no |
|
# <name>-buildversion.txt. Apply the standard Patch/Minor/Major bump rules |
|
# from src/modules/AGENTS.md "Versioning And Releases" - bumping means |
|
# renaming the file AND updating the Meta line above, the manpage_begin line |
|
# below and the provide-block version, then appending a line here): |
|
#0.2.2 - zipfs_tm_UnknownHandler: the builtin-static shortcircuit probe interp no |
|
# longer leaks (G-120). The probe child interp was created under the fixed |
|
# name ptest and deleted only on the non-error paths; an unversioned |
|
# 'package require foo' of a static package made the version check |
|
# 'package vsatisfies $v' throw (wrong # args - vsatisfies needs >=1 |
|
# requirement), skipping the delete. The leaked child held registrations |
|
# on the process std channels (Tcl shares them into non-safe child |
|
# interps), so an explicit 'chan close stderr' left the OS handle alive |
|
# and the std slot occupied - the next opened channel got a fileN name |
|
# instead of recycling into stderr. Now: auto-named probe interp, deleted |
|
# in a try/finally; zero-requirement requires treat any provided version |
|
# as satisfying; probe errors fall through to the normal tm search |
|
# instead of aborting the require. |
|
#0.2.1 - zipfs_tm_UnknownHandler: the zipfs static-path can_skip_update state is |
|
# written keyed by the SPECIFIC searchpath actually scanned (tm path + |
|
# package namespace subdir) to match its reader and libunknown::init's |
|
# indexbase keying. It was written keyed by the tm-list root, so resolving |
|
# any subdir tm (e.g punk::args) poisoned the ROOT's skip map and later |
|
# root-level requires (e.g commandstack) were skipped as known-absent - |
|
# breaking 'shell' on zipfs kits (single //zipfs:/app/modules tm path; |
|
# filesystem tm paths never take the skip branch). Diagnosed 2026-07-20. |
|
#0.2.0 - register_all_tm: deep discovery proc registering ifneeded scripts for |
|
# .tm modules at every namespace depth (once per tm epoch, interp-local |
|
# tm_fullscan guard); used by 'dev lib.search' by default |
|
#0.2.0 - source_pkgindex: pkgIndex.tcl scripts execute in an isolated frame |
|
# ($dir formal + auto_path/env global links) instead of at :: scope - |
|
# user global 'dir' no longer clobbered, index helper vars no longer |
|
# leak into the global namespace ('global dir' removed from |
|
# zipfs_tclPkgUnknown) |
|
#0.1 - initial: epoch-based zipfs_tm_UnknownHandler/zipfs_tclPkgUnknown |
|
# package unknown chain, 'package epoch' command, controlled forget |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_punk::libunknown 0 0.2.2] |
|
#[copyright "2025"] |
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
|
#[require punk::libunknown] |
|
#[keywords module] |
|
#[description] |
|
#[para] - |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section Overview] |
|
#[para] overview of punk::libunknown |
|
#[subsection Concepts] |
|
#[para] - |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[subsection dependencies] |
|
#[para] packages used by punk::libunknown |
|
#[list_begin itemized] |
|
|
|
package require Tcl 8.6- |
|
#*** !doctools |
|
#[item] [package {Tcl 8.6}] |
|
|
|
# #package require frobz |
|
# #*** !doctools |
|
# #[item] [package {frobz}] |
|
|
|
#*** !doctools |
|
#[list_end] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section API] |
|
|
|
|
|
|
|
tcl::namespace::eval ::punk::libunknown { |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Base namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[subsection {Namespace punk::libunknown}] |
|
#[para] Core API functions for punk::libunknown |
|
#[list_begin definitions] |
|
|
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
|
variable PUNKARGS |
|
variable PUNKARGS_aliases |
|
lappend PUNKARGS [list { |
|
@id -id "(package)punk::libunknown" |
|
@package -name "punk::libunknown" -help\ |
|
"Experimental set of replacements for default 'package unknown' entries." |
|
}] |
|
|
|
variable epoch ;#don't set - can be pre-set cooperatively |
|
variable tm_fullscan [dict create] ;#tm epochs fully scanned by register_all_tm. |
|
#Deliberately interp-local (NOT part of the shareable epoch dict): 'package ifneeded' |
|
#registrations are interp-local, so an interp receiving a shared epoch must still run |
|
#its own registration pass (cheap - directory listings come from the shared index cache). |
|
|
|
variable has_package_files |
|
if {[catch {package files foobaz}]} { |
|
set has_package_files 0 |
|
} else { |
|
set has_package_files 1 |
|
} |
|
|
|
if {[info commands ::tcl::Pkg::source] ne ""} { |
|
interp alias "" ::punk::libunknown::tcl_Pkg_source "" ::tcl::Pkg::source |
|
} else { |
|
#early 8.6 - pre tip459? |
|
#we don't have |
|
#::source -nopkg <file> |
|
proc tcl_Pkg_source {filename} { |
|
uplevel 1 [list ::source $filename] |
|
} |
|
} |
|
|
|
#Execute a pkgIndex.tcl script in this proc's frame (tcl_Pkg_source uplevels |
|
#the actual 'source' into its caller). |
|
#The pkgIndex.tcl contract is that $dir holds the index file's directory, and |
|
#stock tclPkgUnknown additionally exposes the auto_path and env globals (some |
|
#indexes, e.g tcllib's, extend auto_path with an unqualified lappend). |
|
#Providing exactly that environment here means anything ELSE the script sets |
|
#stays local to this frame and is discarded - previously indexes were sourced |
|
#via 'namespace eval ::', which clobbered any user global named 'dir' (via the |
|
#handler's since-removed 'global dir') and leaked each index's helper |
|
#variables (ver, pkg, script, ...) into the global namespace. |
|
proc source_pkgindex {dir indexfile} { |
|
global auto_path env |
|
tcl_Pkg_source $indexfile |
|
} |
|
|
|
namespace eval argdoc { |
|
variable PUNKARGS |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::libunknown::zipfs_tm_UnknownHandler |
|
@cmd -name punk::libunknown::zipfs_tm_UnknownHandler\ |
|
-summary\ |
|
"Custom package unknown handler for tcl::tm::list module search paths."\ |
|
-help\ |
|
"Replaces Tcl's built-in ::tcl::tm::UnknownHandler as the first entry in the |
|
package unknown handler chain. Called when package require cannot find a |
|
satisfying version among already-registered ifneeded scripts. |
|
|
|
Key differences from Tcl's standard tm handler: |
|
- Uses an epoch-based cache to avoid re-scanning directories that have already |
|
been searched. The epoch is incremented when tcl::tm::paths changes (via a |
|
trace), invalidating stale cache entries. |
|
- Registers ifneeded scripts for ALL .tm files found in each scanned directory, |
|
not just the requested package — so sibling packages are discovered as a |
|
side effect. |
|
- For static (zipfs) paths, skips re-scanning a directory if the requested |
|
package was not found there in a previous scan within the same epoch. |
|
- Falls through to the next handler (e.g zipfs_tclPkgUnknown) if no satisfying |
|
candidate is found in the tm paths. |
|
|
|
The \$original parameter is the next handler in the package unknown chain, |
|
called as a fallback when the tm search does not satisfy the request." |
|
@leaders |
|
original -type any -help\ |
|
"Next handler in the package unknown chain (list or empty). Called as fallback if the tm search does not satisfy the request." |
|
name -type string -help\ |
|
"Package name being searched for." |
|
@values -min 0 -max -1 |
|
args -type any -optional 1 -multiple 1 -help\ |
|
"Version requirements passed through from package require." |
|
}] |
|
} |
|
#will use standard mechanism for non zipfs paths in the tm list. |
|
proc zipfs_tm_UnknownHandler {original name args} { |
|
#------------------------------ |
|
#shortcircuit for builtin static libraries which have no 'package provide' info - review |
|
#This occurs for example when running 'bin\punk-runtime.cmd run src\make.tcl shell' with punk902z.exe |
|
# |
|
#------------------------------ |
|
set loaded [lsearch -inline -index 1 -nocase [info loaded] $name] |
|
if {[llength $loaded] == 2 && [lindex $loaded 0] eq ""} { |
|
lassign $loaded _ cased_name |
|
#Version-probe the static package in a throwaway child interp. |
|
#The child must never outlive this block: a (non-safe) child interp |
|
#holds registrations on the process std channels, so a leaked probe |
|
#interp disables Tcl's std-slot recycling process-wide (after |
|
#'chan close stderr' the OS handle stays alive and the slot stays |
|
#occupied, so the next opened channel cannot become stderr) - G-120. |
|
set probeinterp [interp create] |
|
try { |
|
interp eval $probeinterp [list load {} $cased_name] |
|
set static_version [interp eval $probeinterp [list package provide [string tolower $cased_name]]] |
|
set pname [string tolower $cased_name] |
|
if {$static_version eq ""} { |
|
set static_version [interp eval $probeinterp [list package provide $cased_name]] |
|
set pname $cased_name |
|
} |
|
if {$static_version ne ""} { |
|
#zero requirements (plain 'package require foo') accepts any |
|
#provided version; package vsatisfies errors without at least |
|
#one requirement argument. |
|
if {![llength $args] || [package vsatisfies $static_version {*}$args]} { |
|
package ifneeded $pname $static_version [list load {} $cased_name] |
|
return |
|
} |
|
} |
|
} on error {} { |
|
#probe failure (e.g a static whose init needs more than a bare |
|
#child interp) - not fatal: fall through to the normal tm search. |
|
} finally { |
|
interp delete $probeinterp |
|
} |
|
} |
|
#------------------------------ |
|
|
|
# Import the list of paths to search for packages in module form. |
|
# Import the pattern used to check package names in detail. |
|
variable epoch |
|
set pkg_epoch [dict get $epoch tm current] |
|
set must_scan 0 |
|
if {[dict exists $epoch tm untracked $name]} { |
|
set must_scan 1 |
|
#a package that was in the package database at the start - is now being searched for as unknown |
|
#our epoch info is not reliable for pre-known packages - so increment the epoch and fully clear the 'added' paths even in zipfs to do proper scan |
|
|
|
#review |
|
#epoch_incr_pkg clearadded |
|
#epoch_incr_tm clearadded |
|
#puts ">>>> removing untracked tm: $name" |
|
dict unset epoch tm untracked $name |
|
#whie it is not the most common configuration - a package could be provided both as a .tm and by packageIndex.tcl files |
|
} |
|
|
|
#variable paths |
|
upvar ::tcl::tm::paths paths |
|
#variable pkgpattern |
|
upvar ::tcl::tm::pkgpattern pkgpattern |
|
|
|
# Without paths to search we can do nothing. (Except falling back to the |
|
# regular search). |
|
set tid [format %-19s -] |
|
catch {set tid [thread::id]} |
|
|
|
if {[llength $paths]} { |
|
set pkgpath [string map {:: /} $name] |
|
set pkgroot [file dirname $pkgpath] |
|
if {$pkgroot eq "."} { |
|
set pkgroot "" |
|
} |
|
|
|
# We don't remember a copy of the paths while looping. Tcl Modules are |
|
# unable to change the list while we are searching for them. This also |
|
# simplifies the loop, as we cannot get additional directories while |
|
# iterating over the list. A simple foreach is sufficient. |
|
|
|
if {[info commands ::tcl::zipfs::root] ne ""} { |
|
set zipfsroot [tcl::zipfs::root] |
|
set has_zipfs 1 |
|
} else { |
|
set zipfsroot "//zipfs:/" ;#doesn't matter much what we use here - don't expect in tm list if no zipfs commands |
|
set has_zipfs 0 |
|
} |
|
|
|
set satisfied 0 |
|
foreach path $paths { |
|
if {![interp issafe] && ![file exists $path]} { |
|
continue |
|
} |
|
set currentsearchpath $path |
|
set specificsearchpath [file join $path $pkgroot] |
|
|
|
# Get the module files out of the subdirectories. |
|
# - Safe Base interpreters have a restricted "glob" command that |
|
# works in this case. |
|
# - The "catch" was essential when there was no safe glob and every |
|
# call in a safe interp failed; it is retained only for corner |
|
# cases in which the eventual call to glob returns an error. |
|
|
|
set use_epoch_for_all 1 |
|
if {$use_epoch_for_all || [string match $zipfsroot* $path]} { |
|
if {!$must_scan && [dict exists $epoch tm epochs $pkg_epoch indexes $specificsearchpath]} { |
|
#indexes are actual .tm files here |
|
set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $specificsearchpath]] |
|
#puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles ( cached ): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath" |
|
} else { |
|
|
|
if {![interp issafe] && ![file exists $specificsearchpath]} { |
|
dict set epoch tm epochs $pkg_epoch indexes $specificsearchpath [dict create] |
|
continue |
|
} |
|
|
|
|
|
dict set epoch tm epochs $pkg_epoch indexes $specificsearchpath [dict create] |
|
|
|
# ################################################################# |
|
if {$has_zipfs && [string match $zipfsroot* $path]} { |
|
#The entire tm tre is available so quickly from the zipfs::list call - that we can gather all at once. |
|
set tmfiles [::tcl::zipfs::list $currentsearchpath/*.tm] ;#could theoretically be a dir - this is effectively a tree traversal |
|
foreach tm_path $tmfiles { |
|
dict set epoch tm epochs $pkg_epoch indexes [file dirname $tm_path] $tm_path $pkg_epoch |
|
} |
|
#retrieval using tcl::zipfs::list got (and cached) extras - limit to specificsearchpath |
|
set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $specificsearchpath]] |
|
} else { |
|
#set tmfiles [glob -nocomplain -directory $currentsearchpath *.tm] |
|
set tmfiles [glob -nocomplain -directory $specificsearchpath *.tm] |
|
foreach tm_path $tmfiles { |
|
#dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath $tm_path $pkg_epoch |
|
dict set epoch tm epochs $pkg_epoch indexes $specificsearchpath $tm_path $pkg_epoch |
|
} |
|
} |
|
#puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles (UNcached): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath" |
|
|
|
# ################################################################# |
|
} |
|
if {![llength $tmfiles]} { |
|
continue |
|
} |
|
|
|
# like normal processing - but track added (for static zipfs) |
|
|
|
set can_skip_update 0 |
|
if {[string match $zipfsroot* $path]} { |
|
#static tm location |
|
if {[dict exists $epoch tm epochs $pkg_epoch added $specificsearchpath]} { |
|
if {![dict exists $epoch tm epochs $pkg_epoch added $specificsearchpath $name]} { |
|
#$name wasn't provided by this path before - in static zipfs it shouldn't be necessary to look here again. |
|
#puts stderr "zipfs_tm_UnknownHandler $tid CAN SKIP orig:$original name:$name args:$args searchpath:$currentsearchpath" |
|
set can_skip_update 1 |
|
} else { |
|
#if this name is in 'added' then we must have done something like a package forget or it wouldn't come back to package unknown |
|
#dict unset epoch tm epochs $pkg_epoch added $currentsearchpath $name |
|
} |
|
} |
|
} |
|
|
|
|
|
if {!$can_skip_update} { |
|
set strip [llength [file split $path]] |
|
set found_name_in_currentsearchpath 0 ;#for negative cache by epoch |
|
if {[catch { |
|
foreach file $tmfiles { |
|
set pkgfilename [join [lrange [file split $file] $strip end] ::] |
|
|
|
if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} { |
|
# Ignore everything not matching our pattern for |
|
# package names. |
|
continue |
|
} |
|
try { |
|
package vcompare $pkgversion 0 |
|
} on error {} { |
|
# Ignore everything where the version part is not |
|
# acceptable to "package vcompare". |
|
continue |
|
} |
|
|
|
if {([package ifneeded $pkgname $pkgversion] ne {}) |
|
&& (![interp issafe]) |
|
} { |
|
# There's already a provide script registered for |
|
# this version of this package. Since all units of |
|
# code claiming to be the same version of the same |
|
# package ought to be identical, just stick with |
|
# the one we already have. |
|
# This does not apply to Safe Base interpreters because |
|
# the token-to-directory mapping may have changed. |
|
|
|
#JMN - review. |
|
#0.2.1: keyed by specificsearchpath (the subset actually scanned) - the |
|
#can_skip_update reader and libunknown::init both key that way; keying by |
|
#the tm-list root here let subdir scans poison root-level skip decisions. |
|
dict set epoch tm epochs $pkg_epoch added $specificsearchpath $pkgname $pkgversion e$pkg_epoch |
|
if {$must_scan} { |
|
#however - if we know we're forced to scan all tm paths we can remove discovered sibling tms from tm untracked |
|
dict unset epoch tm untracked $pkgname |
|
} |
|
if {$pkgname eq $name} { |
|
#can occur multiple times, different versions |
|
#record package name as found in this path whether version satisfies or not |
|
set found_name_in_currentsearchpath 1 |
|
} |
|
#don't override the ifneeded script - for tm files the first encountered 'wins'. |
|
continue |
|
} |
|
|
|
# We have found a candidate, generate a "provide script" |
|
# for it, and remember it. Note that we are using ::list |
|
# to do this; locally [list] means something else without |
|
# the namespace specifier. |
|
|
|
# NOTE. When making changes to the format of the provide |
|
# command generated below CHECK that the 'LOCATE' |
|
# procedure in core file 'platform/shell.tcl' still |
|
# understands it, or, if not, update its implementation |
|
# appropriately. |
|
# |
|
# Right now LOCATE's implementation assumes that the path |
|
# of the package file is the last element in the list. |
|
|
|
package ifneeded $pkgname $pkgversion \ |
|
"[::list package provide $pkgname $pkgversion];[::list source $file]" |
|
|
|
#JMN |
|
#store only once for each name, although there may be multiple versions of same package within this searchpath |
|
#0.2.1: keyed by specificsearchpath - see the matching note at the |
|
#already-ifneeded branch above. |
|
dict set epoch tm epochs $pkg_epoch added $specificsearchpath $pkgname $pkgversion e$pkg_epoch |
|
#pkgname here could be the 'name' passed at the beggning - or other .tms at the same location. |
|
#we can't always remove other .tms from 'tm untracked' because the search for name might skip some locations. |
|
if {$must_scan} { |
|
#however - if we know we're forced to scan all tm paths we can remove discovered sibling tms from tm untracked |
|
dict unset epoch tm untracked $pkgname |
|
} |
|
|
|
# We abort in this unknown handler only if we got a |
|
# satisfying candidate for the requested package. |
|
# Otherwise we still have to fallback to the regular |
|
# package search to complete the processing. |
|
|
|
if {($pkgname eq $name) |
|
&& [package vsatisfies $pkgversion {*}$args]} { |
|
set satisfied 1 |
|
|
|
# We do not abort the loop, and keep adding provide |
|
# scripts for every candidate in the directory, just |
|
# remember to not fall back to the regular search |
|
# anymore. |
|
#(obsolete for libunknown - review) |
|
} |
|
|
|
if {$pkgname eq $name} { |
|
#can occur multiple times, different versions |
|
#record package name as found in this path whether version satisfies or not |
|
set found_name_in_currentsearchpath 1 |
|
} |
|
} |
|
} errMsg]} { |
|
puts stderr "zipfs_tm_Unknownhandler: error for tm file $file searchpath:$currentsearchpath" |
|
} |
|
} |
|
|
|
} else { |
|
#non zipfs tm path - normal processing |
|
# We always look for _all_ possible modules in the current |
|
# path, to get the max result out of the glob. |
|
set tmfiles [glob -nocomplain -directory $currentsearchpath *.tm] |
|
set strip [llength [file split $path]] |
|
catch { |
|
foreach file $tmfiles { |
|
set pkgfilename [join [lrange [file split $file] $strip end] ::] |
|
|
|
if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} { |
|
# Ignore everything not matching our pattern for |
|
# package names. |
|
continue |
|
} |
|
try { |
|
package vcompare $pkgversion 0 |
|
} on error {} { |
|
# Ignore everything where the version part is not |
|
# acceptable to "package vcompare". |
|
continue |
|
} |
|
|
|
if {([package ifneeded $pkgname $pkgversion] ne {}) |
|
&& (![interp issafe]) |
|
} { |
|
# There's already a provide script registered for |
|
# this version of this package. Since all units of |
|
# code claiming to be the same version of the same |
|
# package ought to be identical, just stick with |
|
# the one we already have. |
|
# This does not apply to Safe Base interpreters because |
|
# the token-to-directory mapping may have changed. |
|
continue |
|
} |
|
|
|
# We have found a candidate, generate a "provide script" |
|
# for it, and remember it. Note that we are using ::list |
|
# to do this; locally [list] means something else without |
|
# the namespace specifier. |
|
|
|
# NOTE. When making changes to the format of the provide |
|
# command generated below CHECK that the 'LOCATE' |
|
# procedure in core file 'platform/shell.tcl' still |
|
# understands it, or, if not, update its implementation |
|
# appropriately. |
|
# |
|
# Right now LOCATE's implementation assumes that the path |
|
# of the package file is the last element in the list. |
|
|
|
package ifneeded $pkgname $pkgversion \ |
|
"[::list package provide $pkgname $pkgversion];[::list source $file]" |
|
|
|
# We abort in this unknown handler only if we got a |
|
# satisfying candidate for the requested package. |
|
# Otherwise we still have to fallback to the regular |
|
# package search to complete the processing. |
|
|
|
if {($pkgname eq $name) |
|
&& [package vsatisfies $pkgversion {*}$args]} { |
|
set satisfied 1 |
|
|
|
# We do not abort the loop, and keep adding provide |
|
# scripts for every candidate in the directory, just |
|
# remember to not fall back to the regular search |
|
# anymore. |
|
} |
|
} |
|
} |
|
|
|
} |
|
##ZZZ |
|
|
|
} |
|
|
|
#if {$satisfied} { |
|
# return |
|
#} |
|
} |
|
|
|
# Fallback to previous command, if existing. See comment above about |
|
# ::list... |
|
|
|
if {[llength $original]} { |
|
#puts "zipfs_tm_UnknownHandler passing on to: $original [::linsert $args 0 $name]" |
|
uplevel 1 $original [::linsert $args 0 $name] |
|
} |
|
} |
|
namespace eval argdoc { |
|
variable PUNKARGS |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::libunknown::zipfs_tclPkgUnknown |
|
@cmd -name punk::libunknown::zipfs_tclPkgUnknown\ |
|
-summary\ |
|
"Custom package unknown handler for auto_path/pkgIndex.tcl package search."\ |
|
-help\ |
|
"Replaces Tcl's built-in ::tclPkgUnknown as the second entry in the package |
|
unknown handler chain. Called when zipfs_tm_UnknownHandler could not satisfy |
|
the package request from the tm paths. |
|
|
|
Key differences from Tcl's standard tclPkgUnknown: |
|
- Uses an epoch-based cache to avoid re-sourcing pkgIndex.tcl files that have |
|
already been processed in the current epoch. |
|
- pkgIndex.tcl scripts execute in an isolated frame (see source_pkgindex) |
|
providing the documented \$dir variable plus auto_path/env global links. |
|
Stray unqualified variables set by index scripts stay local to that frame |
|
instead of leaking into the global namespace, and user globals (notably |
|
'dir') are not clobbered. Stock tclPkgUnknown instead exposes all of its |
|
own proc locals to the index scripts. |
|
- Processes auto_path entries from end to front (same as tclPkgUnknown), but |
|
tracks which packages and versions were added or changed by each pkgIndex.tcl |
|
so that ifneeded scripts from earlier (higher-priority) paths can be reverted |
|
if they were overridden by later (lower-priority) paths. |
|
- The refresh/reversion mechanism ensures that path ordering priority is |
|
respected even though auto_path is processed in reverse. |
|
- Handles auto_path expansion: if a pkgIndex.tcl appends to auto_path during |
|
sourcing, the new entries are reordered to follow the longest common prefix |
|
rather than simply appending to the end. |
|
- For static (zipfs) paths, skips re-sourcing pkgIndex.tcl files if the |
|
requested package was not provided by that path in a previous scan." |
|
@leaders |
|
name -type string -help\ |
|
"Package name being searched for." |
|
@values -min 0 -max -1 |
|
args -type any -optional 1 -multiple 1 -help\ |
|
"Version requirements passed through from package require." |
|
}] |
|
} |
|
proc zipfs_tclPkgUnknown {name args} { |
|
#puts "-> zipfs_tclPkgUnknown $name $args EXPERIMENTAL" |
|
|
|
#Note: no 'global dir' here (an earlier revision had one so that pkgIndex.tcl |
|
#scripts sourced at :: scope could read $dir - at the cost of clobbering any |
|
#user global named 'dir'). Index scripts now execute in a source_pkgindex |
|
#frame which provides $dir locally - see source_pkgindex. |
|
|
|
variable epoch |
|
set pkg_epoch [dict get $epoch pkg current] |
|
|
|
#review - the ifneeded script is not the only thing required in a new interp.. consider tclIndex files and auto_load mechanism. |
|
#also the pkgIndex.tcl could possibly provide a different ifneeded script based on interp issafe (or other interp specific things?) |
|
#if {[dict exists $epoch scripts $name]} { |
|
# set vscripts [dict get $epoch scripts $name] |
|
# dict for {v scr} $vscripts { |
|
# puts ">package ifneeded $name $v" |
|
# package ifneeded $name $v $scr |
|
# } |
|
# return |
|
#} |
|
set must_scan 0 |
|
if {[dict exists $epoch pkg untracked $name]} { |
|
#a package that was in the package database at the start - is now being searched for as unknown |
|
#(due to a package forget?) |
|
#our epoch info is not valid for pre-known packages - so setting must_scan to true |
|
set must_scan 1 |
|
#puts ">>>> removing pkg untracked: $name" |
|
dict unset epoch pkg untracked $name |
|
} |
|
|
|
#global auto_path env |
|
global auto_path |
|
|
|
if {![info exists auto_path]} { |
|
return |
|
} |
|
|
|
set tid [format %-19s -] |
|
catch {set tid [thread::id]} |
|
|
|
if {[info commands ::tcl::zipfs::root] ne ""} { |
|
set zipfsroot [tcl::zipfs::root] |
|
set has_zipfs 1 |
|
} else { |
|
set zipfsroot "//zipfs:/" ;#doesn't matter too much what we use here - don't expect in tm list if no zipfs commands |
|
set has_zipfs 0 |
|
} |
|
|
|
|
|
#review - think about this |
|
#typical dict size might be 800 packages - values are versions |
|
#we probably don't need to create/destroy it for each iteration of the wile. |
|
#question is whether some pkgIndex.tcl files may do a package forget? They probably don't/shouldn't(?) Does that matter here anyway? |
|
set before_dict [dict create] |
|
|
|
#J2 |
|
#siblings that have been affected by source scripts - need to retest ifneeded scripts at end for proper ordering. |
|
set refresh_dict [dict create] |
|
|
|
#Note that autopath is being processed from the end to the front |
|
#ie last lappended first. This means if there are duplicate versions earlier in the list, |
|
#they will be the last to call 'package provide' for that version and so their provide script will 'win'. |
|
#This means we should have faster filesystems such as zipfs earlier in the list. |
|
|
|
# Cache the auto_path, because it may change while we run through the |
|
# first set of pkgIndex.tcl files |
|
set old_path [set use_path $auto_path] |
|
while {[llength $use_path]} { |
|
set dir [lindex $use_path end] |
|
|
|
|
|
# Make sure we only scan each directory one time. |
|
if {[info exists tclSeenPath($dir)]} { |
|
set use_path [lrange $use_path 0 end-1] |
|
continue |
|
} |
|
set tclSeenPath($dir) 1 |
|
|
|
# Get the pkgIndex.tcl files in subdirectories of auto_path directories. |
|
# - Safe Base interpreters have a restricted "glob" command that |
|
# works in this case. |
|
# - The "catch" was essential when there was no safe glob and every |
|
# call in a safe interp failed; it is retained only for corner |
|
# cases in which the eventual call to glob returns an error. |
|
|
|
set use_epoch_for_all 1 |
|
if {$use_epoch_for_all || [string match $zipfsroot* $dir]} { |
|
set currentsearchpath $dir |
|
if {!$must_scan && [dict exists $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]} { |
|
set indexfiles [dict keys [dict get $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]] |
|
#puts stderr "--->zipfs_tclPkgUnknown $tid llength tmfiles ( cached ): [format %4d [llength $indexfiles]] name:$name searchpath:$currentsearchpath" |
|
} else { |
|
dict set epoch pkg epochs $pkg_epoch indexes $currentsearchpath [dict create] |
|
# ################################################################# |
|
set indexpaths [glob -directory $currentsearchpath -join -nocomplain * pkgIndex.tcl] |
|
foreach idxpath $indexpaths { |
|
dict set epoch pkg epochs $pkg_epoch indexes $currentsearchpath $idxpath 1 |
|
} |
|
set indexfiles [dict keys [dict get $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]] |
|
#puts stderr "--->zipfs_tclPkgUnknown $tid llength tmfiles (UNcached): [format %4d [llength $indexfiles]] name:$name searchpath:$currentsearchpath" |
|
# ################################################################# |
|
} |
|
if {![llength $indexfiles]} { |
|
continue |
|
} |
|
|
|
set can_skip_sourcing 0 |
|
#if {$has_zipfs && [string match $zipfsroot* $dir]} { |
|
#static auto_path dirs |
|
if {!$must_scan} { |
|
if {[dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath]} { |
|
if {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} { |
|
#$name wasn't provided by this path before - in static zipfs it shouldn't be necessary to look here again. |
|
#puts stderr "zipfs_tclPkgUnknown $tid CAN SKIP $name currentsearchpath:$currentsearchpath" |
|
set can_skip_sourcing 1 |
|
} else { |
|
#if this name is in added then we must have done a package forget or it wouldn't come back to package unknown ? |
|
#remove it and let it be readded if it's still provided by this path? |
|
#probably doesn't make sense for static path? |
|
#dict unset epoch pkg epochs $pkg_epoch added $currentsearchpath $name |
|
} |
|
} |
|
} |
|
#} |
|
|
|
|
|
|
|
#An edge case exception is that after a package forget, a deliberate call to 'package require non-existant' |
|
#will not trigger rescans for all versions of other packages. |
|
#A rescan of a specific package for all versions can still be triggered with a package require for |
|
#an exact non-existant version. e.g package require md5 0-0 |
|
#(or misordered min max e.g package require md5 1-0 i.e a deliberately unsatisfiable version range) |
|
|
|
set sourced 0 |
|
set just_added [dict create] |
|
set just_changed [dict create] |
|
#set sourced_files [list] |
|
|
|
#J2 |
|
#set can_skip_sourcing 0 |
|
|
|
if {!$can_skip_sourcing} { |
|
#Note - naive comparison of before_pkgs vs after_pkgs isn't quite enough to tell if something was added. It could have added a version. |
|
#this will stop us rescanning everything properly by doing a 'package require nonexistant' |
|
|
|
#use 'info exists' to only call package names once and then append? |
|
#This could be problematic? (re-entrant tclPkgUnknown in some pkgIndex scripts?) pkgIndex.tcl scripts "shouldn't" do this? |
|
if {![info exists before_pkgs]} { |
|
set before_pkgs [package names] |
|
#update the before_dict which persists across while loop |
|
#we need to track the actual 'ifneeded' script not just version numbers, |
|
#because the last ifneeded script processed for each version is the one that ultimately applies. |
|
foreach bp $before_pkgs { |
|
#dict set before_dict $bp [package versions $bp] |
|
foreach v [package versions $bp] { |
|
dict set before_dict $bp $v [package ifneeded $bp $v] |
|
} |
|
} |
|
} |
|
#set before_pkgs [package names] |
|
|
|
#catch { |
|
foreach file $indexfiles { |
|
set dir [file dirname $file] |
|
if {![info exists procdDirs($dir)]} { |
|
try { |
|
#if {[string match //zipfs*registry* $file]} { |
|
# puts stderr "----->0 sourcing zipfs file $file" |
|
#} |
|
incr sourced ;#count as sourced even if source fails; keep before actual source action |
|
#lappend sourced_files $file |
|
source_pkgindex $dir $file |
|
} trap {POSIX EACCES} {} { |
|
# $file was not readable; silently ignore |
|
puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (1)" |
|
continue |
|
} on error msg { |
|
if {[regexp {version conflict for package} $msg]} { |
|
# In case of version conflict, silently ignore |
|
puts stderr "zipfs_tclPkgUnknown version conflict sourcing '$file' while trying to load $name (1)\nmsg:$msg" |
|
continue |
|
} |
|
tclLog "error reading package index file $file: $msg" |
|
} on ok {} { |
|
set procdDirs($dir) 1 |
|
} |
|
} |
|
#each source operation could affect auto_path - and thus increment the pkg epoch (via trace on ::auto_path) |
|
#e.g tcllib pkgIndex.tcl appends to auto_path |
|
set pkg_epoch [dict get $epoch pkg current] |
|
} |
|
#} |
|
set dir [lindex $use_path end] |
|
if {![info exists procdDirs($dir)]} { |
|
set file [file join $dir pkgIndex.tcl] |
|
# safe interps usually don't have "file exists", |
|
if {([interp issafe] || [file exists $file])} { |
|
try { |
|
#puts "----->2 sourcing $file" |
|
incr sourced |
|
#lappend sourced_files $file |
|
source_pkgindex $dir $file |
|
} trap {POSIX EACCES} {} { |
|
# $file was not readable; silently ignore |
|
puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (2)" |
|
continue |
|
} on error msg { |
|
if {[regexp {version conflict for package} $msg]} { |
|
# In case of version conflict, silently ignore |
|
puts stderr "zipfs_tclPkgUnknown version conflict sourcing '$file' while trying to load $name (2)\nmsg:$msg" |
|
continue |
|
} |
|
tclLog "error reading package index file $file: $msg" |
|
} on ok {} { |
|
set procdDirs($dir) 1 |
|
} |
|
set pkg_epoch [dict get $epoch pkg current] |
|
} |
|
} |
|
#dict set epoch pkg epochs $pkg_epoch added $currentsearchpath [dict create] |
|
|
|
#avoid calculating package and version diffs if nothing was actually sourced |
|
if {$sourced > 0} { |
|
if {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath]} { |
|
dict set epoch pkg epochs $pkg_epoch added $currentsearchpath [dict create] |
|
#ensure there is an empty entry for the path if no packages added or changed versions |
|
} |
|
|
|
set after_pkgs [package names] |
|
#puts "@@@@pkg epochs $pkg_epoch searchpath:$currentsearchpath name:$name before: [llength $before_pkgs] after: [llength $after_pkgs]" |
|
if {[llength $after_pkgs] > [llength $before_pkgs]} { |
|
foreach a $after_pkgs { |
|
foreach v [package versions $a] { |
|
if {![dict exists $before_dict $a $v]} { |
|
dict set just_added $a $v 1 |
|
set iscript [package ifneeded $a $v] |
|
#J2 |
|
#dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a [dict create e $pkg_epoch v $v] |
|
dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a $v [dict create e $pkg_epoch scr $iscript] |
|
if {$must_scan} { |
|
dict unset epoch pkg untracked $a |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
#----------------- |
|
#if {[dict size $just_added]} { |
|
# puts stderr "\x1b\[31m>>>zipfs_tclPkgUnknown called on name:$name added [dict size $just_added] from searchpath:$currentsearchpath\x1b\[m" |
|
# puts stderr ">>> [join [lrange [dict keys $just_added] 0 10] \n]..." |
|
#} else { |
|
# tclLog ">>>zipfs_tclPkgUnknown called on name:$name Nothing added for searchpath:$currentsearchpath" |
|
# if {[string match twapi* $name]} { |
|
# tclLog ">>>zipfs_tclPkgUnknown: sourced_files:" |
|
# foreach f $sourced_files { |
|
# puts ">>> $f" |
|
# } |
|
# } |
|
# if {$currentsearchpath in "//zipfs:/app //zipfs:/app/tcl_library"} { |
|
# puts " before_pkgs: [llength $before_pkgs]" |
|
# puts " lsearch msgcat: [lsearch $before_pkgs msgcat]" |
|
# puts " after_pkgs: [llength $after_pkgs]" |
|
# puts " \x1b\31mlsearch msgcat: [lsearch $after_pkgs msgcat]\x1b\[m" |
|
# if {[lsearch $after_pkgs msgcat] >=0} { |
|
# set versions [package versions msgcat] |
|
# puts "msgcat versions: $versions" |
|
# foreach v $versions { |
|
# puts "\x1b\[32m $v ifneeded: [package ifneeded msgcat $v] \x1b\[m" |
|
# } |
|
# } |
|
# } |
|
#} |
|
#----------------- |
|
|
|
#review - just because this searchpath didn't add a package or add a version for the package |
|
#it doesn't mean there wasn't a version of this package supplied there |
|
#It may just be the same version as one we've already found. |
|
#The last one found (earlier in auto_path) for a version is the one that supplies the final 'package provide' statement (by overriding it) |
|
# |
|
dict for {bp bpversionscripts} $before_dict { |
|
#if {!$must_scan && ![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $bp]} { |
|
# #puts -nonewline . |
|
# continue |
|
#} |
|
dict for {bv bscript} $bpversionscripts { |
|
set nowscript [package ifneeded $bp $bv] |
|
if {$bscript ne $nowscript} { |
|
#ifneeded script has changed. The same version of bp was supplied on this path. |
|
#As it's processed later - it will be the one in effect. |
|
#dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp [dict create e $pkg_epoch v $bv] |
|
dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp $bv [dict create e $pkg_epoch scr $nowscript] |
|
dict set before_dict $bp $bv $nowscript |
|
dict set just_changed $bp $bv 1 |
|
#j2 |
|
if {$must_scan} { |
|
dict unset epoch pkg untracked $bp |
|
} |
|
} |
|
} |
|
} |
|
|
|
#update before_pkgs & before_dict for next path |
|
dict for {newp vdict} $just_added { |
|
if {$newp ni $before_pkgs} { |
|
lappend before_pkgs $newp |
|
} |
|
dict for {v _} $vdict { |
|
set nowscript [package ifneeded $newp $v] |
|
dict set before_dict $newp $v $nowscript |
|
} |
|
} |
|
} |
|
} |
|
|
|
} else { |
|
#normal processing - not a static filesystem - we can't skip. |
|
set indexfiles [glob -directory $dir -join -nocomplain * pkgIndex.tcl] |
|
catch { |
|
foreach file $indexfiles { |
|
set dir [file dirname $file] |
|
if {![info exists procdDirs($dir)]} { |
|
try { |
|
#puts "----->1 sourcing $file" |
|
::tcl::Pkg::source $file |
|
} trap {POSIX EACCES} {} { |
|
# $file was not readable; silently ignore |
|
continue |
|
} on error msg { |
|
if {[regexp {version conflict for package} $msg]} { |
|
# In case of version conflict, silently ignore |
|
continue |
|
} |
|
tclLog "error reading package index file $file: $msg" |
|
} on ok {} { |
|
set procdDirs($dir) 1 |
|
} |
|
} |
|
} |
|
} |
|
|
|
set dir [lindex $use_path end] |
|
if {![info exists procdDirs($dir)]} { |
|
set file [file join $dir pkgIndex.tcl] |
|
# safe interps usually don't have "file exists", |
|
if {([interp issafe] || [file exists $file])} { |
|
try { |
|
#puts "----->2 sourcing $file" |
|
::tcl::Pkg::source $file |
|
} trap {POSIX EACCES} {} { |
|
# $file was not readable; silently ignore |
|
continue |
|
} on error msg { |
|
if {[regexp {version conflict for package} $msg]} { |
|
# In case of version conflict, silently ignore |
|
continue |
|
} |
|
tclLog "error reading package index file $file: $msg" |
|
} on ok {} { |
|
set procdDirs($dir) 1 |
|
} |
|
} |
|
} |
|
|
|
} |
|
|
|
|
|
set use_path [lrange $use_path 0 end-1] |
|
|
|
# Check whether any of the index scripts we [source]d above set a new |
|
# value for $::auto_path. If so, then find any new directories on the |
|
# $::auto_path, and lappend them to the $use_path we are working from. |
|
# This gives index scripts the (arguably unwise) power to expand the |
|
# index script search path while the search is in progress. |
|
set index 0 |
|
if {[llength $old_path] == [llength $auto_path]} { |
|
foreach dir $auto_path old $old_path { |
|
if {$dir ne $old} { |
|
# This entry in $::auto_path has changed. |
|
break |
|
} |
|
incr index |
|
} |
|
} |
|
|
|
# $index now points to the first element of $auto_path that has |
|
# changed, or the beginning if $auto_path has changed length Scan the |
|
# new elements of $auto_path for directories to add to $use_path. |
|
# Don't add directories we've already seen, or ones already on the |
|
# $use_path. |
|
foreach dir [lrange $auto_path $index end] { |
|
if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} { |
|
lappend use_path $dir |
|
} |
|
} |
|
set old_path $auto_path |
|
|
|
dict for {pkg versions} $just_changed { |
|
foreach v [dict keys $versions] { |
|
dict set refresh_dict $pkg $v 1 |
|
} |
|
} |
|
dict for {pkg versions} $just_added { |
|
foreach v [dict keys $versions] { |
|
dict set refresh_dict $pkg $v 1 |
|
} |
|
} |
|
} |
|
|
|
#refresh ifneeded scripts for just_added/just_changed |
|
#review: searchpaths are in auto_path order - earliest has precedence for any particular pkg-version |
|
|
|
#REVIEW: what is to stop an auto_path package e.g from os, overriding a .tm ifneeded script from an item earlier in the package_mode list configured in punk's main.tcl? |
|
#e.g when package_mode is {dev-os} we don't want a pkgIndex package from ::env(TCLLIBPATH) overriding a .tm from the dev paths (even if version nums the same) |
|
#conversely we do want a dev path pkIndex package overriding an existing ifneeded script from a .tm in os |
|
#to accomodate this - we may need to maintain a subdict in epoch of paths/path-prefixes to package_mode members os, dev, internal |
|
|
|
#this 'refresh' is really a 'reversion' to what was already stored in epoch pkg epochs <currente> added |
|
# |
|
|
|
set e [dict get $epoch pkg current] |
|
set pkgvdone [dict create] |
|
set dict_added [dict get $epoch pkg epochs $e added] |
|
#keys are in reverse order due to tclPkgUnknown processing order |
|
set ordered_searchpaths [lreverse [dict keys $dict_added]];# ordered as in auto_path |
|
|
|
#JN todo - look at tm epochs |
|
dict for {pkg versiond} $refresh_dict { |
|
set versions [dict keys $versiond] |
|
#puts stderr "---->pkg:$pkg versions: $versions" |
|
foreach searchpath $ordered_searchpaths { |
|
set addedinfo [dict get $dict_added $searchpath] |
|
set vidx -1 |
|
foreach v $versions { |
|
incr vidx |
|
if {[dict exists $addedinfo $pkg $v]} { |
|
ledit versions $vidx $vidx ;incr vidx -1 ;#maintain vidx as index into current state of $versions - not original state the foreach operates across. |
|
set iscript [dict get $addedinfo $pkg $v scr] |
|
#todo - find the iscript in the '$epoch pkg epochs <e> added paths' lists and determine os vs dev vs internal |
|
#(scanning for path directly in the ifneeded script for pkgs is potentially error prone) |
|
#for .tm ifneeded scripts - the syntax is simple enough to determine directly (and ifneeded scr not stored for those anyway) |
|
set justaddedscript [package ifneeded $pkg $v] |
|
if {$justaddedscript ne $iscript} { |
|
#puts "---->refreshing $pkg $v - reverting to already stored from path:$searchpath versions: $versions" |
|
package ifneeded $pkg $v $iscript |
|
#dict set pkgvdone $pkg $v 1 |
|
} |
|
} |
|
} |
|
if {[llength $versions] == 0} { |
|
break |
|
} |
|
} |
|
} |
|
|
|
|
|
#puts "zipfs_tclPkgUnknown DONE" |
|
} |
|
variable last_auto_path |
|
variable last_tm_paths |
|
proc epoch_incr_pkg {args} { |
|
if {[catch { |
|
variable last_auto_path |
|
global auto_path |
|
upvar ::punk::libunknown::epoch epoch |
|
dict set epoch scripts {} |
|
set prev_e [dict get $epoch pkg current] |
|
set current_e [expr {$prev_e + 1}] |
|
# ------------- |
|
#puts stderr "--> pkg epoch $prev_e -> $current_e" |
|
#puts stderr "args: $args" |
|
#puts stderr "last_auto: $last_auto_path" |
|
#puts stderr "auto_path: $auto_path" |
|
# ------------- |
|
if {[llength $auto_path] > [llength $last_auto_path] && [punk::libunknown::lib::is_list_all_in_list $last_auto_path $auto_path]} { |
|
#The auto_path changed, and is a pure addition of entry/entries |
|
#commonly this is occurs where a single entry is added by a pkgIndex.Tcl |
|
#e.g tcllib adds its base dir so that all pkgIndex.tcl files in subdirs are subsequently found |
|
#consider autopath |
|
#c:/libbase //zipfs:/app/libbase |
|
#if both contain a tcllib folder with pkgIndex.tcl that extends auto_path, the auto_path extends as follows: |
|
# -> c:/libbase //zipfs:/app/libbase //zipfs:/app/libbase/tcllib |
|
# -> c:/libbase //zipfs:/app/libbase //zipfs:/app/libbase/tcllib c:/libbase/tcllib |
|
|
|
#the tclPkgUnknown usedir loop (working from end of list towards beginning) will process these changes the first time dynamically |
|
#as they occur: |
|
#ie //zipfs:/app/libbase //zipfs:/app/libbase/tcllib c:/libbase c:/libbase/tcllib |
|
|
|
#A subsequent scan by tclPkgUnknown on the extended auto_path would process in the order: |
|
#c:/libbase/tcllib c:/libbase //zipfs:/app/libbase/tcllib //zipfs:/app/libbase |
|
|
|
#re-order the new additions to come immediately following the longest common prefix entry |
|
|
|
set newitems [punk::libunknown::lib::ldiff $auto_path $last_auto_path] |
|
|
|
set update $last_auto_path |
|
#no ledit or punk::lib::compat::ledit for 8.6 - so use linsert |
|
foreach new $newitems { |
|
set offset 0 |
|
set has_prefix 0 |
|
foreach ap [lreverse $update] { |
|
if {[string match $ap* $new]} { |
|
set has_prefix 1 |
|
break |
|
} |
|
incr offset |
|
} |
|
if {$has_prefix} { |
|
set update [linsert $update end-$offset $new] |
|
#end based index used with linsert - so can't replace with ledit. |
|
} else { |
|
lappend update $new |
|
} |
|
} |
|
set auto_path $update |
|
|
|
|
|
} |
|
#else - if auto_path change wasn't just extra entries - leave as user specified |
|
#review. |
|
|
|
set last_auto_path $auto_path |
|
# ------------- |
|
dict set epoch pkg current $current_e |
|
dict set epoch pkg epochs $current_e [dict create] |
|
if {[info commands ::tcl::zipfs::root] ne ""} { |
|
set has_zipfs 1 |
|
} else { |
|
set has_zipfs 0 |
|
} |
|
|
|
if {[dict exists $epoch pkg epochs $prev_e indexes]} { |
|
#bring across each previous 'indexes' record *if* searchpath is within zipfs root static filesystem |
|
# and searchpath is still a path below an auto_path entry. |
|
if {$has_zipfs} { |
|
set zroot [zipfs root] |
|
dict for {searchpath indexfiles} [dict get $epoch pkg epochs $prev_e indexes] { |
|
if {[string match $zroot* $searchpath]} { |
|
set stillvalid 0 |
|
foreach a $auto_path { |
|
if {[string match $a* $searchpath]} { |
|
set stillvalid 1 |
|
break |
|
} |
|
} |
|
if {$stillvalid} { |
|
dict set epoch pkg epochs $current_e indexes $searchpath $indexfiles |
|
} |
|
} |
|
} |
|
} |
|
|
|
#---------------------------------------- |
|
#store basic stats for previous epoch instead of all data. |
|
set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e indexes]] |
|
set index_count 0 |
|
dict for {searchpath indexfiles} [dict get $epoch pkg epochs $prev_e indexes] { |
|
#update prev epoch to be basic statistical info only |
|
incr index_count [llength $indexfiles] |
|
} |
|
dict set epoch pkg epochs $prev_e indexes_history [dict create searchpath_count $index_searchpath_count index_count $index_count] |
|
dict unset epoch pkg epochs $prev_e indexes |
|
#---------------------------------------- |
|
} else { |
|
dict set epoch pkg epochs $prev_e indexes_history [dict create searchpath_count 0 index_count 0] |
|
} |
|
if {[dict exists $epoch pkg epochs $prev_e added]} { |
|
if {"clearadded" in $args} { |
|
dict set epoch pkg epochs $current_e added [dict create] |
|
} else { |
|
if {$has_zipfs} { |
|
set zroot [zipfs root] |
|
set prev_added [dict get $epoch pkg epochs $prev_e added] |
|
set keep_added [dict filter $prev_added key $zroot*] |
|
#bring across - each lib will have previous epoch number as the value indicating epoch in which it was found |
|
#dict set epoch pkg epochs $current_e added [dict get $epoch pkg epochs $prev_e added] |
|
dict set epoch pkg epochs $current_e added $keep_added |
|
} else { |
|
dict set epoch pkg epochs $current_e added [dict create] |
|
} |
|
} |
|
|
|
#store basic stats for previous epoch |
|
#------------------------------------ |
|
set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e added]] |
|
set lib_count 0 |
|
dict for {searchpath libinfo} [dict get $epoch pkg epochs $prev_e added] { |
|
dict for {lib e} $libinfo { |
|
if {$e == $prev_e} { |
|
incr lib_count |
|
} |
|
} |
|
} |
|
dict set epoch pkg epochs $prev_e added_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] |
|
dict unset epoch pkg epochs $prev_e added |
|
#------------------------------------ |
|
} else { |
|
dict set epoch pkg epochs $prev_e added_history [dict create searchpath_count 0 lib_count 0] |
|
} |
|
} errM]} { |
|
puts stderr "epoch_incr_pkg error\n $errM\n$::errorInfo" |
|
} |
|
} |
|
proc epoch_incr_tm {args} { |
|
if {[catch { |
|
upvar ::punk::libunknown::epoch epoch |
|
dict set epoch scripts {} |
|
set prev_e [dict get $epoch tm current] |
|
set current_e [expr {$prev_e + 1}] |
|
dict set epoch tm current $current_e |
|
dict set epoch tm epochs $current_e [dict create] |
|
set tmlist [tcl::tm::list] |
|
if {[info commands ::tcl::zipfs::root] ne ""} { |
|
set has_zipfs 1 |
|
} else { |
|
set has_zipfs 0 |
|
} |
|
if {[dict exists $epoch tm epochs $prev_e indexes]} { |
|
#bring across the previous indexes records if static filesystem (zipfs) |
|
if {$has_zipfs} { |
|
set zroot [zipfs root] |
|
dict for {searchpath indexfiles} [dict get $epoch tm epochs $prev_e indexes] { |
|
if {[string match $zroot* $searchpath]} { |
|
#check all valid for current state of tcl::tm::list |
|
set stillvalid 0 |
|
foreach tm_path $tmlist { |
|
if {[string match $tm_path* $searchpath]} { |
|
set stillvalid 1 |
|
break |
|
} |
|
} |
|
if {$stillvalid} { |
|
dict set epoch tm epochs $current_e indexes $searchpath $indexfiles |
|
} |
|
} |
|
} |
|
} |
|
set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e indexes]] |
|
set index_count 0 |
|
dict for {searchpath indexfiles} [dict get $epoch tm epochs $prev_e indexes] { |
|
#update prev epoch to be basic statistical info only |
|
incr index_count [llength $indexfiles] |
|
} |
|
dict set epoch tm epochs $prev_e indexes_history [dict create searchpath_count $index_searchpath_count index_count $index_count] |
|
dict unset epoch tm epochs $prev_e indexes |
|
} else { |
|
dict set epoch tm epochs $prev_e indexes_history [dict create searchpath_count 0 index_count 0] |
|
} |
|
if {[dict exists $epoch tm epochs $prev_e added]} { |
|
#todo? cycle through non-statics and add pkgs to pkg untracked if we are deleting 'added' records? |
|
if {"clearadded" in $args} { |
|
dict set epoch tm epochs $current_e added [dict create] |
|
} else { |
|
#bring across - each lib will have previous epoch number |
|
#dict set epoch tm epochs $current_e added [dict get $epoch tm epochs $prev_e added] |
|
if {$has_zipfs} { |
|
set zroot [zipfs root] |
|
dict set epoch tm epochs $current_e added [dict filter [dict get $epoch tm epochs $prev_e added] key $zroot*] |
|
} else { |
|
dict set epoch tm epochs $current_e added [dict create] |
|
} |
|
} |
|
|
|
|
|
set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e added]] |
|
set lib_count 0 |
|
dict for {searchpath libinfo} [dict get $epoch tm epochs $prev_e added] { |
|
dict for {lib e} $libinfo { |
|
if {$e == $prev_e} { |
|
incr lib_count |
|
} |
|
} |
|
} |
|
dict set epoch tm epochs $prev_e added_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] |
|
dict unset epoch tm epochs $prev_e added |
|
} else { |
|
dict set epoch tm epochs $prev_e added_history [dict create searchpath_count 0 lib_count 0] |
|
} |
|
|
|
} errM]} { |
|
puts stderr "epoch_incr_tm error\n $errM" |
|
} |
|
} |
|
|
|
namespace eval argdoc { |
|
variable PUNKARGS |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::libunknown::register_all_tm |
|
@cmd -name punk::libunknown::register_all_tm\ |
|
-summary\ |
|
"Deep discovery: register ifneeded scripts for all .tm modules at every namespace depth."\ |
|
-help\ |
|
"Walks every path in tcl::tm::list recursively and registers a 'package ifneeded' |
|
script for each .tm module found - including modules in namespace subfolders |
|
that have never been requested. (The tm package unknown handler registers |
|
sibling .tm files only at the namespace depth of the package being required, |
|
so such modules are otherwise absent from 'package names' until first |
|
requested.) |
|
|
|
Existing ifneeded scripts are never overridden - first registration wins, |
|
matching the tm unknown handler, so head-of-tm-list precedence for |
|
same-version modules is preserved. |
|
|
|
Uses and populates the same per-epoch directory index cache as the unknown |
|
handlers: for zipfs (static) paths the whole tree listing is gathered in one |
|
call; for filesystem paths each directory's *.tm glob is cached per |
|
'package epoch'. Directories named #modpod-*, #tarjar-* and _build are |
|
skipped. |
|
|
|
The scan runs at most once per tm epoch per interp (tracked in the |
|
interp-local tm_fullscan variable - deliberately not part of the shareable |
|
epoch dict, because ifneeded registrations are interp-local; an interp |
|
receiving a shared epoch re-registers cheaply from the cached indexes). |
|
Path-list changes and 'package epoch incr' start a new tm epoch, |
|
re-enabling the scan - a call after 'package epoch incr' re-reads the |
|
filesystem and picks up modules added or removed on disk. |
|
|
|
Returns a stats dict: epoch, roots, dirs, tmfiles, registered - plus |
|
'cached 1' when the call was a per-epoch no-op. |
|
|
|
punk::libunknown::init must have been called first." |
|
@opts |
|
-force -type none -help\ |
|
"Run the registration pass even if already performed in the current tm epoch. |
|
Directory listings still come from the epoch index cache where present - |
|
use 'package epoch incr' first to force re-reading the filesystem." |
|
}] |
|
} |
|
proc register_all_tm {args} { |
|
variable epoch |
|
if {![info exists epoch]} { |
|
error "punk::libunknown::register_all_tm - punk::libunknown::init has not been called in this interp" |
|
} |
|
set opt_force [expr {"-force" in $args}] |
|
variable tm_fullscan |
|
set tm_epoch [dict get $epoch tm current] |
|
if {!$opt_force && [dict exists $tm_fullscan $tm_epoch]} { |
|
return [dict merge [dict get $tm_fullscan $tm_epoch] [dict create cached 1]] |
|
} |
|
upvar ::tcl::tm::paths paths |
|
upvar ::tcl::tm::pkgpattern pkgpattern |
|
|
|
if {[info commands ::tcl::zipfs::root] ne ""} { |
|
set zipfsroot [tcl::zipfs::root] |
|
set has_zipfs 1 |
|
} else { |
|
set zipfsroot "//zipfs:/" ;#doesn't matter much what we use here - don't expect in tm list if no zipfs commands |
|
set has_zipfs 0 |
|
} |
|
set stat_roots 0 |
|
set stat_dirs 0 |
|
set stat_files 0 |
|
set stat_registered 0 |
|
foreach path $paths { |
|
if {![interp issafe] && ![file exists $path]} { |
|
continue |
|
} |
|
incr stat_roots |
|
set tmfiles [list] |
|
if {$has_zipfs && [string match $zipfsroot* $path]} { |
|
#static filesystem - the whole tm tree is available in one quick call |
|
#(as the tm unknown handler's zipfs branch does) |
|
set tmfiles [::tcl::zipfs::list $path/*.tm] |
|
set seen_dirs [dict create] |
|
foreach tm_path $tmfiles { |
|
set d [file dirname $tm_path] |
|
dict set seen_dirs $d 1 |
|
dict set epoch tm epochs $tm_epoch indexes $d $tm_path $tm_epoch |
|
} |
|
incr stat_dirs [dict size $seen_dirs] |
|
} else { |
|
#plain filesystem - breadth-first walk, reusing/populating the per-epoch |
|
#directory index cache so the unknown handlers can short-circuit later |
|
set pending [list $path] |
|
while {[llength $pending]} { |
|
set current [lindex $pending 0] |
|
set pending [lrange $pending 1 end] |
|
incr stat_dirs |
|
if {[dict exists $epoch tm epochs $tm_epoch indexes $current]} { |
|
set dirfiles [dict keys [dict get $epoch tm epochs $tm_epoch indexes $current]] |
|
} else { |
|
set dirfiles [glob -nocomplain -directory $current -types f *.tm] |
|
dict set epoch tm epochs $tm_epoch indexes $current [dict create] |
|
foreach f $dirfiles { |
|
dict set epoch tm epochs $tm_epoch indexes $current $f $tm_epoch |
|
} |
|
} |
|
lappend tmfiles {*}$dirfiles |
|
foreach sub [glob -nocomplain -directory $current -types d *] { |
|
set tail [file tail $sub] |
|
if {[string match "#modpod-*" $tail] || [string match "#tarjar-*" $tail] || $tail eq "_build"} { |
|
continue |
|
} |
|
lappend pending $sub |
|
} |
|
} |
|
} |
|
#registration - same rules as the tm unknown handler (don't override existing |
|
#ifneeded scripts: for tm modules the first encountered 'wins') |
|
set strip [llength [file split $path]] |
|
foreach file $tmfiles { |
|
if {[string match "*/_build/*" $file]} { |
|
continue |
|
} |
|
incr stat_files |
|
set pkgfilename [join [lrange [file split $file] $strip end] ::] |
|
if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} { |
|
# Ignore everything not matching our pattern for package names. |
|
continue |
|
} |
|
try { |
|
package vcompare $pkgversion 0 |
|
} on error {} { |
|
# Ignore everything where the version part is not acceptable to |
|
# "package vcompare". |
|
continue |
|
} |
|
if {([package ifneeded $pkgname $pkgversion] ne {}) && (![interp issafe])} { |
|
#already registered - possibly by an earlier (higher precedence) path |
|
dict set epoch tm epochs $tm_epoch added $path $pkgname $pkgversion e$tm_epoch |
|
dict unset epoch tm untracked $pkgname |
|
continue |
|
} |
|
package ifneeded $pkgname $pkgversion \ |
|
"[::list package provide $pkgname $pkgversion];[::list source $file]" |
|
incr stat_registered |
|
dict set epoch tm epochs $tm_epoch added $path $pkgname $pkgversion e$tm_epoch |
|
dict unset epoch tm untracked $pkgname |
|
} |
|
} |
|
set stats [dict create epoch $tm_epoch roots $stat_roots dirs $stat_dirs tmfiles $stat_files registered $stat_registered] |
|
dict set tm_fullscan $tm_epoch $stats |
|
return $stats |
|
} |
|
|
|
#see what basic info we can gather *quickly* about the indexes for each version of a pkg that the package db knows about. |
|
#we want no calls out to the actual filesystem - but we can use some 'file' calls such as 'file dirname', 'file split' (review -safe interp problem) |
|
#in practice the info is only available for tm modules |
|
proc packagedb_indexinfo {pkg} { |
|
if {[string match ::* $pkg]} { |
|
error "packagedb_indexinfo: package name required - not a fully qualified namespace beginning with :: Received:'$pkg'" |
|
} |
|
set versions [lsort -command {package vcompare} [package versions $pkg]] |
|
if {[llength $versions] == 0} { |
|
set v [package provide $pkg] |
|
} |
|
set versionlist [list] |
|
foreach v $versions { |
|
set ifneededscript [package ifneeded $pkg $v] |
|
if {[string trim $ifneededscript] eq ""} { |
|
lappend versionlist [list $v type unknown index "" indexbase ""] |
|
continue |
|
} |
|
set scriptlines [split $ifneededscript \n] |
|
if {[llength $scriptlines] > 1} { |
|
lappend versionlist [list $v type unknown index "" indexbase ""] |
|
continue |
|
} |
|
if {[catch {llength $ifneededscript}]} { |
|
#scripts aren't necessarily 'list shaped' - we don't want to get into the weeds trying to make sense of arbitrary scripts. |
|
lappend versionlist [list $v type unknown index "" indexbase ""] |
|
continue |
|
} |
|
if {[lindex $ifneededscript 0] eq "package" && [lindex $ifneededscript 1] eq "provide" && [file extension [lindex $ifneededscript end]] eq ".tm"} { |
|
set tmfile [lindex $ifneededscript end] |
|
set nspath [namespace qualifiers $pkg] |
|
if {$nspath eq ""} { |
|
set base [file dirname $tmfile] |
|
} else { |
|
set nsparts [string map {:: " "} $nspath] ;#*naive* split - we are assuming (fairly reasonably) there are no namespaces containing spaces for a .tm module |
|
set pathparts [file split [file dirname $tmfile]] |
|
set baseparts [lrange $pathparts 0 end-[llength $nsparts]] |
|
set base [file join {*}$baseparts] |
|
} |
|
lappend versionlist [list $v type tm index $tmfile indexbase $base script $ifneededscript] |
|
} else { |
|
#we could guess at the pkgindex.tcl file used based on simple pkg ifneeded scripts .tcl path compared to ::auto_index |
|
#but without hitting filesystem to verify - it's unsatisfactory |
|
lappend versionlist [list $v type unknown index "" indexbase "" script $ifneededscript] |
|
} |
|
} |
|
return $versionlist |
|
} |
|
namespace eval argdoc { |
|
variable PUNKARGS |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::libunknown::init |
|
@cmd -name punk::libunknown::init\ |
|
-summary\ |
|
"Install punk::libunknown's custom package unknown handlers and epoch system in the current interp."\ |
|
-help\ |
|
"Renames the builtin ::package to ::package:: and installs a custom ::package proc |
|
that intercepts 'forget' (controlled forgetting) and adds an 'epoch' subcommand |
|
(for introspection). Sets package unknown to a two-handler chain: |
|
zipfs_tm_UnknownHandler (tm paths) and zipfs_tclPkgUnknown (auto_path/pkgIndex). |
|
|
|
Installs traces on ::auto_path and ::tcl::tm::paths that increment the epoch |
|
when these change, invalidating stale scan cache entries. |
|
|
|
Epoch sharing: if \$::punk::libunknown::epoch is already set before init is called |
|
(e.g copied from a parent interp via punk::lib::interp_sync_package_paths -libunknown 1), |
|
init accepts it as a pre-provided record and uses the parent's scan cache instead |
|
of building one from scratch. Packages that were already known before the epoch was |
|
set are recorded as 'untracked' — full scans are performed for them on first request. |
|
|
|
This proc should be called as early as possible in a new interp or thread, before |
|
any package require calls that would trigger scans, to minimize the number of |
|
untracked packages and maximize cache effectiveness. |
|
|
|
See also: punk::lib::interp_sync_package_paths, punk::lib::snapshot_package_paths" |
|
@opts |
|
-caller -type string -default "" -help\ |
|
"Informational label identifying the calling context (e.g 'main.tcl', 'repl::init init_script'). |
|
Used only for debug logging — does not affect behaviour." |
|
}] |
|
} |
|
proc init {args} { |
|
variable last_auto_path |
|
set last_auto_path [set ::auto_path] |
|
variable last_tm_paths |
|
set last_tm_paths [set ::tcl::tm::paths] |
|
|
|
set callerposn [lsearch $args -caller] |
|
if {$callerposn > -1} { |
|
set caller [lindex $args $callerposn+1] |
|
if {[package provide thread] ne ""} { |
|
set tid [thread::id] |
|
} else { |
|
set tid "-" |
|
} |
|
#puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller tid:$tid\x1b\[m" |
|
#puts stderr "punk::libunknown::init auto_path : $::auto_path" |
|
#puts stderr "punk::libunknown::init tcl::tm::list: [tcl::tm::list]" |
|
} |
|
|
|
|
|
|
|
|
|
if {[catch {tcl::tm::list} tmlist]} { |
|
set tmlist [list] |
|
} |
|
set apath [list] |
|
if {[info commands tcl::tm::list] ne ""} { |
|
set tmlist [tcl::tm::list] |
|
} |
|
if {[info exists ::auto_path]} { |
|
set apath $::auto_path |
|
} |
|
if {![llength $tmlist] && ![llength $apath]} { |
|
#shouldn't happen - be noisy about it for now |
|
puts stderr "punk::libunknown::init - init while empty/unreadable tcl::tm::list and empty/unreadable ::auto_path" |
|
} |
|
|
|
if {[info commands ::punk::libunknown::package] ne ""} { |
|
puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]" |
|
return |
|
} |
|
#if {[namespace origin ::package] eq "::punk::libunknown::package"} { |
|
# #This is far from conclusive - there may be other renamers (e.g commandstack) |
|
# return |
|
#} |
|
|
|
|
|
|
|
variable epoch |
|
if {![info exists epoch]} { |
|
set tmstate [dict create 0 {added {}}] |
|
set pkgstate [dict create 0 {added {}}] |
|
set tminfo [dict create current 0 epochs $tmstate untracked [dict create]] |
|
set pkginfo [dict create current 0 epochs $pkgstate untracked [dict create]] |
|
|
|
set epoch [dict create scripts {} tm $tminfo pkg $pkginfo] |
|
|
|
#untracked: package names at time of punk::libunknown::init call - or passed with epoch when sharing epoch to another interp. |
|
#The epoch state will need to be incremented and cleared of any 'added' records if any of these are requested during a package unknown call |
|
#Because they were loaded prior to us tracking the epochs - and without trying to examine the ifneeded scripts we don't know the exact paths |
|
#which were scanned to load them. Our 'added' key entries will not contain them because they weren't unknown |
|
} else { |
|
#we're accepting a pre-provided 'epoch' record (probably from another interp) |
|
#the tm untracked and pkg untracked dicts indicate for which packages the pkg added, tm added etc data are not conclusive |
|
#test |
|
#todo? |
|
} |
|
#upon first libunknown::init in the interp, we need to add any of this interp's already known packages to the (possibly existing) tm untracked and pkg untracked dicts. |
|
#(unless we can use packagedb_indexinfo to determine what was previously scanned?) |
|
# review - what if the auto_path or tcl::tm::list was changed between initial scan and call of libunknown::init??? |
|
# This is likely a common scenario?!!! |
|
# For now this is a probable flaw in the logic - we need to ensure libunknown::init is done first thing |
|
# or suffer additional scans.. or document ?? |
|
#ideally init should be called in each interp before any scans for packages so that the list of untracked is minimized. |
|
set pkgnames [package names] |
|
#puts stderr "####### punk::libunknown init called with [llength $pkgnames] package names known" |
|
foreach p $pkgnames { |
|
if {[string tolower $p] in {punk::libunknown tcl::zlib tcloo tcl::oo tcl}} { |
|
continue |
|
} |
|
set versions [package versions $p] |
|
if {[llength $versions] == 0} { |
|
continue |
|
} |
|
set versionlist [packagedb_indexinfo $p] |
|
if {[llength $versionlist] == 0} { |
|
continue |
|
} else { |
|
foreach vdata $versionlist { |
|
#dict set epoch scripts $p [lindex $vdata 0] [package ifneeded $p [lindex $vdata 0]] |
|
dict set epoch scripts $p [lindex $vdata 0] [lindex $vdata 8]] |
|
} |
|
if {[lsearch -index 6 $versionlist ""] > -1} { |
|
#There exists at least one empty indexbase for this package - we have to treat it as untracked |
|
dict set epoch tm untracked $p "" ;#value unimportant |
|
dict set epoch pkg untracked $p "" ;#value unimportant |
|
} else { |
|
#update the epoch info with where the tm versions came from |
|
#(not tracking version numbers in epoch - just package to the indexbase) |
|
foreach vdata $versionlist { |
|
lassign $vdata v _t type _index index _indexbase indexbase _script iscript |
|
if {$type eq "tm"} { |
|
if {![dict exists $epoch tm epochs 0 added $indexbase]} { |
|
#dict set epoch tm epochs 0 added $indexbase [dict create $p [dict create e 0 v $v]] |
|
dict set epoch tm epochs 0 added $indexbase $p $v [dict create e 0 scr $iscript] |
|
} else { |
|
set idxadded [dict get $epoch tm epochs 0 added $indexbase] |
|
#dict set idxadded $p [dict create e 0 v $v] |
|
dict set idxadded $p $v [dict create e 0 scr $iscript] |
|
dict set epoch tm epochs 0 added $indexbase $idxadded |
|
} |
|
dict unset epoch tm untracked $p |
|
} elseif {$type eq "pkg"} { |
|
#todo? tcl doesn't give us good introspection on package indexes for packages |
|
#dict unset epoch pkg untracked $p |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
#------------------------------------------------------------- |
|
#set all_untracked [dict keys [dict get $epoch untracked]] |
|
#puts stderr "\x1b\[1\;33m punk::libunknown::init - pkg all_untracked:\x1b\[m [dict size [dict get $epoch pkg untracked]]" |
|
#if {[dict exists $epoch pkg untracked msgcat]} { |
|
# puts stderr "\x1b\[1\;32m punk::libunknown::init msgcat found in pkg untracked \x1b\[m " |
|
# set versions [package versions msgcat] |
|
# puts stderr "versions: $versions" |
|
# foreach v $versions { |
|
# puts stdout "v $v ifneeded: [package ifneeded msgcat $v]" |
|
# } |
|
#} else { |
|
# puts stderr "\x1b\[1\;31m punk::libunknown::init msgcat NOT found in pkg untracked \x1b\[m " |
|
#} |
|
#puts stderr "\x1b\[1\;33m punk::libunknown::init - tm all_untracked:\x1b\[m [dict size [dict get $epoch tm untracked]]" |
|
#if {[dict exists $epoch tm untracked msgcat]} { |
|
# puts stderr "\x1b\[1\;32m punk::libunknown::init msgcat found in tm untracked \x1b\[m " |
|
# set versions [package versions msgcat] |
|
# puts stderr "versions: $versions" |
|
# foreach v $versions { |
|
# puts stdout "v $v ifneeded: [package ifneeded msgcat $v]" |
|
# } |
|
#} else { |
|
# puts stderr "\x1b\[1\;31m punk::libunknown::init msgcat NOT found in tm untracked \x1b\[m " |
|
#} |
|
#------------------------------------------------------------- |
|
|
|
trace add variable ::auto_path write ::punk::libunknown::epoch_incr_pkg |
|
trace add variable ::tcl::tm::paths write ::punk::libunknown::epoch_incr_tm |
|
#set stackrecord [commandstack::rename_command -renamer punk::libunknown package {args} { |
|
# #::package override installed by punk::libunknown::init |
|
#} |
|
proc package args { |
|
switch -- [lindex $args 0] { |
|
fo - for - forge - forget { |
|
variable has_package_files |
|
#experimental - silently disallow forgetting things that didn't involve sourcing files |
|
#What about static libs that also sourced files? |
|
#packages loaded by c extensions? |
|
#forgetting Tcl or tcl seems to be a bad idea - package require doesn't work afterwards (independent of this pkg) |
|
set forgets_requested [lrange $args 1 end] |
|
set ok_forgets [list] |
|
upvar ::punk::libunknown::epoch epoch |
|
foreach p $forgets_requested { |
|
#'package files' not avail in early 8.6 |
|
#There can be other custom 'package ifneeded' scripts that don't use source - but still need to be forgotten. |
|
#a basic/trivial case: 'package ifneeded aaa 0.1.1 {package provide aaa 0.1.1}' |
|
#it could also use 'eval' instead of sourcing. |
|
#For this reason - we shouldn't use 'package files' as any sort of indication of forgetability |
|
#if {$p ni {tcl Tcl} && (!$has_package_files || [package provide $p] eq "" || ($has_package_files && [package provide $p] ne "" && [llength [package files $p]] > 0))} { |
|
# lappend ok_forgets $p |
|
#} |
|
#What then? Hardcoded only for now? |
|
if {$p ni {tcl Tcl tcl::oo tk}} { |
|
#tcl::oo returns a comment only for its package provide script "# Already present, OK?" |
|
# - so we can't use empty 'ifneeded' script as a determinant. |
|
set vpresent [package provide $p] |
|
if {$vpresent ne ""} { |
|
#There could theoretically be other ifneeded scripts registered - but if the one in use is empty |
|
#we'll use that as the criteria to disallow forget - REVIEW |
|
set ifneededscript [package ifneeded $p $vpresent] |
|
if {[string trim $ifneededscript] ne ""} { |
|
lappend ok_forgets $p |
|
dict unset epoch scripts $p |
|
} |
|
} else { |
|
#not loaded - but may have registered ifneeded script(s) in the package database |
|
#assume ok to forget |
|
lappend ok_forgets $p |
|
dict unset epoch scripts $p |
|
} |
|
} |
|
} |
|
if {[llength $ok_forgets]} { |
|
return [uplevel 1 [list ::package:: forget {*}$ok_forgets]] |
|
} else { |
|
return |
|
} |
|
} |
|
ep - epo - epoc - epoch { |
|
upvar ::punk::libunknown::epoch epoch |
|
set epoch_args [lrange $args 1 end] |
|
switch -- [llength $epoch_args] { |
|
0 { |
|
set tm_epoch [dict get $epoch tm current] |
|
set pkg_epoch [dict get $epoch pkg current] |
|
return [dict create tm $tm_epoch pkg $pkg_epoch] |
|
} |
|
1 { |
|
switch -- [lindex $epoch_args 0] { |
|
tm { |
|
set cur [dict get $epoch tm current] |
|
return [dict create $cur [dict get $epoch tm epochs $cur]] |
|
} |
|
pkg { |
|
set cur [dict get $epoch pkg current] |
|
return [dict create $cur [dict get $epoch pkg epochs $cur]] |
|
} |
|
incr { |
|
epoch_incr_pkg |
|
epoch_incr_tm |
|
} |
|
default { |
|
error "package epoch [lindex $epoch_args 0] unsupported - known options: tm pkg incr" |
|
} |
|
} |
|
} |
|
2 { |
|
set a2 [list [lindex $epoch_args 0] [lindex $epoch_args 1]] |
|
switch -- $a2 { |
|
{pkg incr} - {incr pkg} { |
|
epoch_incr_pkg |
|
} |
|
{tm incr} - {incr tm} { |
|
epoch_incr_tm |
|
} |
|
default { |
|
set which [lindex $epoch_args 0] |
|
set index [lindex $epoch_args 1] |
|
if {$which in {pkg tm}} { |
|
set epochs [dict keys [dict get $epoch $which epochs]] |
|
if {[catch { |
|
set epochinfo [dict get $epoch $which epochs $index] |
|
} errM]} { |
|
error "package epoch $which <idx> unable to use index $index" |
|
} |
|
return $epochinfo |
|
} else { |
|
error "package epoch {*}$a2 unsupported - expected 'pkg incr' or 'tm incr' or 'pkg <index>' or 'tm <index>'" |
|
} |
|
} |
|
} |
|
} |
|
default { |
|
set which [lindex $epoch_args 0] |
|
set index [lindex $epoch_args 1] |
|
set keys [lrange $epoch_args 2 end] |
|
if {$which in {pkg tm}} { |
|
set epochs [dict keys [dict get $epoch $which epochs]] |
|
if {[catch { |
|
set epochinfo [dict get $epoch $which epochs $index] |
|
} errM]} { |
|
error "package epoch $which <idx> unable to use index $index" |
|
} |
|
if {![dict exists $epochinfo {*}$keys]} { |
|
set topkeys [dict keys $epochinfo] |
|
error "package epoch $which $index $keys not found. Toplevel keys: $topkeys" |
|
} |
|
return [dict get $epochinfo {*}$keys] |
|
} else { |
|
error "package epoch <args> unimplemented" |
|
} |
|
} |
|
} |
|
} |
|
default { |
|
return [uplevel 1 [list ::package:: {*}$args]] |
|
} |
|
} |
|
} |
|
rename ::package ::package:: |
|
#all lowercase procs already exported from ::punk::libunknown |
|
namespace eval :: [list ::namespace import ::punk::libunknown::package] |
|
|
|
#if {[info commands ::tcl::zipfs::root] ne ""} { |
|
# set has_zipfs_tm 0 |
|
# foreach t $tmlist { |
|
# if {[string match [::tcl::zipfs::root]* $t]} { |
|
# set has_zipfs_tm 1 |
|
# break ;#zipfs_tm_UnknownHandler can handle either - a single zipfs path is enough |
|
# } |
|
# } |
|
# set has_zipfs_auto 0 |
|
# foreach a $apath { |
|
# if {[string match [::tcl::zipfs::root]* $a]} { |
|
# set has_zipfs_auto 1 |
|
# break |
|
# } |
|
# } |
|
# if {$has_zipfs_tm || $has_zipfs_auto} { |
|
# if {$has_zipfs_tm && $has_zipfs_auto} { |
|
# package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} |
|
# } elseif {$has_zipfs_tm} { |
|
# package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::tclPkgUnknown} |
|
# } else { |
|
# #must only have auto |
|
# #puts "tmlist : $tmlist" |
|
# #puts "autopath: $apath" |
|
# package unknown {::tcl::tm::UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} |
|
# } |
|
# } |
|
# #review - tm and auto_path entries for safebase interps are obscured. For now we will ignore and defaults will apply. |
|
# #to load in safebase anyway - module would probably have to be passed to interp as source to eval? |
|
#} |
|
|
|
if {![interp issafe]} { |
|
#J2 |
|
package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} |
|
#package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::tclPkgUnknown} |
|
} |
|
|
|
} |
|
|
|
proc default {} { |
|
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} |
|
} |
|
|
|
namespace eval argdoc { |
|
variable PUNKARGS |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::libunknown::package_query |
|
@cmd -name punk::libunknown::package_query\ |
|
-summary\ |
|
"Diagnostic tool showing epoch tracking and scan cache state for a named package."\ |
|
-help\ |
|
"Returns a text report showing what punk::libunknown knows about the given |
|
package from its epoch-based scan cache. The report includes: |
|
|
|
- Whether the package is in the tm or pkg 'untracked' sets (packages that were |
|
already known before libunknown::init was called, meaning the epoch data is |
|
not conclusive for them). |
|
- A table of auto_path directories (pkg epoch) showing which packages were found |
|
in each, with version numbers and epoch stamps for the requested package. |
|
- A table of tcl::tm::list directories (tm epoch) showing which packages were |
|
found in each, with version numbers for the requested package. |
|
|
|
This is primarily a developer diagnostic for understanding why a particular |
|
package version was (or was not) loaded, and which search path provided it. |
|
Requires punk::ansi and textblock for the table formatting." |
|
@values -min 1 -max 1 |
|
pkgname -type string -help\ |
|
"Name of the package to inspect." |
|
}] |
|
} |
|
proc package_query {pkgname} { |
|
variable epoch |
|
|
|
if {[dict exists $epoch tm untracked $pkgname]} { |
|
set pkg_info "$pkgname tm UNTRACKED" |
|
} else { |
|
set pkg_info "$pkgname not in tm untracked" |
|
} |
|
if {[dict exists $epoch pkg untracked $pkgname]} { |
|
append pkg_info \n "$pkgname pkg UNTRACKED" |
|
} else { |
|
append pkg_info \n "$pkgname not in pkg untracked" |
|
} |
|
|
|
set pkg_epoch [dict get $epoch pkg current] |
|
#set epoch_info [dict get $epoch pkg epochs $pkg_epoch] |
|
#pkg entries are processed by package unknown in reverse - so their order of creaation is opposite to ::auto_path |
|
set r_added [dict create] |
|
foreach path [lreverse [dict keys [dict get $epoch pkg epochs $pkg_epoch added]]] { |
|
dict set r_added $path [dict get $epoch pkg epochs $pkg_epoch added $path] |
|
} |
|
|
|
#set pkg_added [punk::lib::showdict $r_added */$pkgname] |
|
#set added [textblock::frame -title $title $pkg_added] |
|
set rows [list] |
|
dict for {path pkgs} $r_added { |
|
set c1 $path |
|
set c2 [dict size $pkgs] |
|
set c3 "" |
|
if {[dict exists $pkgs $pkgname]} { |
|
set vdict [dict get $pkgs $pkgname] |
|
dict for {v data} $vdict { |
|
set scriptlen [string length [dict get $data scr]] |
|
append c3 "$v epoch[dict get $data e] ifneededchars:$scriptlen" \n |
|
} |
|
} |
|
set r [list $path $c2 $c3] |
|
lappend rows $r |
|
} |
|
set title "[punk::ansi::a+ green] PKG epoch $pkg_epoch - added [punk::ansi::a]" |
|
set added [textblock::table -title $title -headers [list Path Pkgcount $pkgname] -rows $rows] |
|
|
|
|
|
set pkg_row $added |
|
|
|
set tm_epoch [dict get $epoch tm current] |
|
#set tm_added [punk::lib::showdict [dict get $epoch tm epochs $tm_epoch added] */$pkgname] |
|
set added [dict get $epoch tm epochs $tm_epoch added] |
|
set rows [list] |
|
dict for {path pkgs} $added { |
|
set c1 $path |
|
set c2 [dict size $pkgs] |
|
set c3 "" |
|
if {[dict exists $pkgs $pkgname]} { |
|
set vdict [dict get $pkgs $pkgname] |
|
dict for {v data} $vdict { |
|
append c3 "$v $data" \n |
|
} |
|
} |
|
set r [list $c1 $c2 $c3] |
|
lappend rows $r |
|
} |
|
set title "TM epoch $tm_epoch - added" |
|
#set added [textblock::frame -title $title $tm_added] |
|
set added [textblock::table -title $title -headers [list Path Tmcount $pkgname] -rows $rows] |
|
|
|
set tm_row $added |
|
|
|
return $pkg_info\n$pkg_row\n$tm_row |
|
} |
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::libunknown ---}] |
|
} |
|
# == === === === === === === === === === === === === === === |
|
|
|
namespace eval ::punk::libunknown { |
|
#for 8.6 compat |
|
if {"::ledit" ni [info commands ::ledit]} { |
|
#maint: taken from punk::lib |
|
proc ledit {lvar first last args} { |
|
upvar $lvar l |
|
#use lindex_resolve to support for example: ledit lst end+1 end+1 h i |
|
set fidx [lindex_resolve [llength $l] $first] |
|
switch -exact -- $fidx { |
|
-Inf { |
|
#index below lower bound |
|
set pre [list] |
|
set fidx -1 |
|
} |
|
Inf { |
|
#first index position is greater than index of last element in the list |
|
set pre [lrange $l 0 end] |
|
set fidx [llength $l] |
|
} |
|
default { |
|
set pre [lrange $l 0 $first-1] |
|
} |
|
} |
|
set lidx [lindex_resolve [llength $l] $last] |
|
switch -exact -- $lidx { |
|
-Inf { |
|
#index below lower bound |
|
set post [lrange $l 0 end] |
|
} |
|
Inf { |
|
#index above upper bound |
|
set post [list] |
|
} |
|
default { |
|
if {$lidx < $fidx} { |
|
#from ledit man page: |
|
#If last is less than first, then any specified elements will be inserted into the list before the element specified by first with no elements being deleted. |
|
set post [lrange $l $fidx end] |
|
} else { |
|
set post [lrange $l $last+1 end] |
|
} |
|
} |
|
} |
|
set l [list {*}$pre {*}$args {*}$post] |
|
} |
|
|
|
#maint: taken from punk::lib |
|
proc lindex_resolve {len index} { |
|
if {![string is integer -strict $len]} { |
|
#<0 ? |
|
error "lindex_resolve len must be an integer" |
|
} |
|
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 |
|
if {[string is integer -strict $index]} { |
|
#can match +i -i |
|
if {$index < 0} { |
|
return -Inf |
|
} elseif {$index >= $len} { |
|
return Inf |
|
} else { |
|
#integer may still have + sign - normalize with expr |
|
return [expr {$index}] |
|
} |
|
} else { |
|
if {[string match end* $index]} { |
|
if {$index ne "end"} { |
|
set op [string index $index 3] |
|
set offset [string range $index 4 end] |
|
if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} |
|
if {$op eq "+" && $offset != 0} { |
|
return Inf |
|
} |
|
} else { |
|
#index is 'end' |
|
set index [expr {$len-1}] |
|
if {$index < 0} { |
|
#special case - 'end' with empty list - treat end like a positive number out of bounds |
|
return Inf |
|
} else { |
|
return $index |
|
} |
|
} |
|
if {$offset == 0} { |
|
set index [expr {$len-1}] |
|
if {$index < 0} { |
|
return Inf ;#special case as above |
|
} else { |
|
return $index |
|
} |
|
} else { |
|
#by now, if op = + then offset = 0 so we only need to handle the minus case |
|
set index [expr {($len-1) - $offset}] |
|
} |
|
if {$index < 0} { |
|
return -Inf |
|
} else { |
|
return $index |
|
} |
|
} else { |
|
#plain +-<int> already handled above. |
|
#we are trying to avoid evaluating unbraced expr of potentially insecure origin |
|
if {[regexp {(.*)([+-])(.*)} $index _match a op b]} { |
|
if {[string is integer -strict $a] && [string is integer -strict $b]} { |
|
if {$op eq "-"} { |
|
set index [expr {$a - $b}] |
|
} else { |
|
set index [expr {$a + $b}] |
|
} |
|
} else { |
|
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" |
|
} |
|
} else { |
|
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" |
|
} |
|
if {$index < 0} { |
|
return -Inf |
|
} elseif {$index >= $len} { |
|
return Inf |
|
} |
|
return $index |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
tcl::namespace::eval ::punk::libunknown::lib { |
|
|
|
#A version of textutil::string::longestCommonPrefixList |
|
#(also as ::punk::lib::longestCommonPrefixList) |
|
proc longestCommonPrefix {items} { |
|
if {[llength $items] <= 1} { |
|
return [lindex $items 0] |
|
} |
|
#set items [lsort $items[unset items]] |
|
set items [lsort $items[set items {}]] |
|
set min [lindex $items 0] |
|
set max [lindex $items end] |
|
#if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) |
|
#(sort order nothing to do with length - e.g min may be longer than max) |
|
if {[string length $min] > [string length $max]} { |
|
set temp $min |
|
set min $max |
|
set max $temp |
|
} |
|
set n [string length $min] |
|
set prefix "" |
|
set i -1 |
|
while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { |
|
append prefix $c |
|
} |
|
return $prefix |
|
} |
|
#maint: from punk::lib::ldiff |
|
proc ldiff {fromlist removeitems} { |
|
if {[llength $removeitems] == 0} {return $fromlist} |
|
set result [list] |
|
foreach item $fromlist { |
|
if {$item ni $removeitems} { |
|
lappend result $item |
|
} |
|
} |
|
return $result |
|
} |
|
proc intersect2 {A B} { |
|
#taken from tcl version of struct::set::Intersect |
|
if {[llength $A] == 0} {return {}} |
|
if {[llength $B] == 0} {return {}} |
|
|
|
# This is slower than local vars, but more robust |
|
if {[llength $B] > [llength $A]} { |
|
::set res $A |
|
::set A $B |
|
::set B $res |
|
} |
|
::set res {} |
|
foreach x $A { |
|
::set ($x) {} |
|
} |
|
foreach x $B { |
|
if {[info exists ($x)]} { |
|
lappend res $x |
|
} |
|
} |
|
return $res |
|
} |
|
proc is_list_all_in_list {A B} { |
|
if {[llength $A] > [llength $B]} {return 0} |
|
foreach x $B { |
|
::set ($x) {} |
|
} |
|
foreach x $A { |
|
if {![info exists ($x)]} { |
|
return 0 |
|
} |
|
} |
|
return 1 |
|
} |
|
} |
|
|
|
# ----------------------------------------------------------------------------- |
|
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
|
# ----------------------------------------------------------------------------- |
|
# variable PUNKARGS |
|
# variable PUNKARGS_aliases |
|
namespace eval ::punk::args::register { |
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
|
lappend ::punk::args::register::NAMESPACES ::punk::libunknown |
|
} |
|
# ----------------------------------------------------------------------------- |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::libunknown [tcl::namespace::eval ::punk::libunknown { |
|
variable pkg punk::libunknown |
|
variable version |
|
set version 0.2.2 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end] |
|
|
|
|