From cc5300400d06d8c1be0a78af9e027feaa2b35456 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Mon, 5 May 2025 12:42:42 +1000 Subject: [PATCH] punk::libunknown - package unknown system --- src/modules/punk/libunknown-0.1.tm | 1039 +++++++++++++++++ .../punk/packagepreference-999999.0a1.0.tm | 2 +- src/modules/punk/repl-999999.0a1.0.tm | 143 ++- src/vendormodules/commandstack-0.3.tm | 6 +- src/vendormodules/modpod-0.1.3.tm | 25 +- src/vfs/_config/modules/punk/libunknown.tm | 673 ----------- src/vfs/_config/punk_main.tcl | 4 +- src/vfs/_vfscommon.vfs/lib/xxx/pkgIndex.tcl | 5 + src/vfs/_vfscommon.vfs/lib/xxx/xxx-0.1.3.tm | 50 + .../modules/commandstack-0.3.tm | 6 +- .../_vfscommon.vfs/modules/modpod-0.1.3.tm | 25 +- .../modules/punk/libunknown-0.1.tm | 1039 +++++++++++++++++ .../modules/punk/packagepreference-0.1.0.tm | 2 +- .../_vfscommon.vfs/modules/punk/repl-0.1.1.tm | 143 ++- src/vfs/_vfscommon.vfs/modules/xxx-0.1.2.tm | 50 + ...known.tm#@punk%3a%3aboot,merge_over#.fxlnk | 0 16 files changed, 2455 insertions(+), 757 deletions(-) create mode 100644 src/modules/punk/libunknown-0.1.tm delete mode 100644 src/vfs/_config/modules/punk/libunknown.tm create mode 100644 src/vfs/_vfscommon.vfs/lib/xxx/pkgIndex.tcl create mode 100644 src/vfs/_vfscommon.vfs/lib/xxx/xxx-0.1.3.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/xxx-0.1.2.tm delete mode 100644 src/vfs/punk9win.vfs/modules/punk/libunknown.tm#..+_config+modules+punk+libunknown.tm#@punk%3a%3aboot,merge_over#.fxlnk diff --git a/src/modules/punk/libunknown-0.1.tm b/src/modules/punk/libunknown-0.1.tm new file mode 100644 index 00000000..24e2abc7 --- /dev/null +++ b/src/modules/punk/libunknown-0.1.tm @@ -0,0 +1,1039 @@ +# -*- tcl -*- +# module template: shellspy/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.1 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::libunknown 0.1] +#[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 + if {![info exists epoch]} { + set tmstate [dict create 0 {}] + set pkgstate [dict create 0 {}] + set tminfo [dict create current 0 epochs $tmstate] + set pkginfo [dict create current 0 epochs $pkgstate] + + set epoch [dict create tm $tminfo pkg $pkginfo] + } + + 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 + proc tcl_Pkg_source {filename} { + uplevel 1 [list ::source $filename] + } + } + + #will use standard mechanism for non zipfs paths in the tm list. + proc zipfs_tm_UnknownHandler {original name args} { + # 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] + + + #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 [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 {[dict exists $epoch tm epochs $pkg_epoch indexes $currentsearchpath]} { + #indexes are actual .tm files here + set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $currentsearchpath]] + #puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles ( cached ): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath" + } else { + + if {![interp issafe] && ![file exists $currentsearchpath]} { + dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath [dict create] + continue + } + + + dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath [dict create] + + # ################################################################# + if {$has_zipfs && [string match $zipfsroot* $path]} { + 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 currentsearchpath + set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $currentsearchpath]] + } else { + set tmfiles [glob -nocomplain -directory $currentsearchpath *.tm] + foreach tm_path $tmfiles { + dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath $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 $currentsearchpath]} { + if {![dict exists $epoch tm 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_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 + } + } + } else { + #dynamic - can only skip if negatively cached for the current epoch + if {[dict exists $epoch tm epochs $pkg_epoch unfound $currentsearchpath $name]} { + #puts stderr "zipfs_tm_UnknownHandler $tid CAN SKIP $name currentsearchpath:$currentsearchpath (unfound already in epoch $pkg_epoch)" + set can_skip_update 1 + } + + } + + if {!$can_skip_update} { + set strip [llength [file split $path]] + set found_name_in_currentsearchpath 0 ;#for negative cache by epoch + 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]" + + #JMN + #store only once for each name, although there may be multiple versions + dict set epoch tm epochs $pkg_epoch added $currentsearchpath $pkgname $pkg_epoch + + # 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 + } + } + } + if {!$found_name_in_currentsearchpath} { + #can record as unfound for this path - for this epoch + dict set epoch tm epochs $pkg_epoch unfound $currentsearchpath $name 1 + } + } + + } 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] + } + } + proc zipfs_tclPkgUnknown {name args} { + #puts "-> zipfs_tclPkgUnknown $name $args EXPERIMENTAL" + + variable epoch + set pkg_epoch [dict get $epoch pkg current] + + + #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 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] + + + # 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 {[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 + #can avoid scan if added via this path in any epoch + 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 + } + } + } else { + #dynamic auto_path dirs - libs could have been added/removed + #scan unless cached negative for this epoch + if {[dict exists $epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name]} { + #puts stderr "zipfs_tclPkgUnknown $tid CAN SKIP $name currentsearchpath:$currentsearchpath (unfound already in epoch $pkg_epoch)" + set can_skip_sourcing 1 + } + } + #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 + 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? worth it? + if {![info exists before_pkgs]} { + set before_pkgs [package names] + } + #update the before_dict which persists across while loop + foreach bp $before_pkgs { + dict set before_dict $bp [package versions $bp] + } + catch { + foreach file $indexfiles { + set dir [file dirname $file] + if {![info exists procdDirs($dir)]} { + try { + #puts stderr "----->0 sourcing $file" + incr sourced ;#count as sourced even if source fails; keep before actual source action + #::tcl::Pkg::source $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" + incr sourced + #::tcl::Pkg::source $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 + } + } + } + #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] + set just_added [dict create] + if {[llength $after_pkgs] > [llength $before_pkgs]} { + foreach a $after_pkgs { + if {![dict exists $before_dict $a]} { + dict set just_added $a 1 + dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a $pkg_epoch + } + } + #puts stderr ">>>zipfs_tclPkgUnknown added [llength $added_pkgs]" + #puts stderr ">>> [join [lrange $added_pkgs 0 10] \n]..." + } + dict for {bp bpversions} $before_dict { + if {[dict exists $just_added $bp]} { + continue + } + if {[llength $bpversions] != [llength [package versions $bp]]} { + dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp $pkg_epoch + } + } + #puts stderr "zipfs_tclPkgUnknown $tid sourced: $sourced (under path: $currentsearchpath)" + if {$name ni $after_pkgs} { + #cache negative result (for this epoch only) + dict set epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name 1 + } elseif {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} { + dict set epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name 1 + } + + lappend before_pkgs {*}[dict keys $just_added] + } + } + + } 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 + } + #puts "zipfs_tclPkgUnknown DONE" + } + proc epoch_incr_pkg {args} { + if {[catch { + global auto_path + upvar ::punk::libunknown::epoch epoch + set prev_e [dict get $epoch pkg current] + set current_e [expr {$prev_e + 1}] + dict set epoch pkg current $current_e + dict set epoch pkg epochs $current_e [dict create] + if {[dict exists $epoch pkg epochs $prev_e indexes]} { + #bring across the previous indexes records if static filesystem (zipfs) + if {[info commands ::tcl::zipfs::root] ne ""} { + 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 + } + } + } + } + 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]} { + #bring across - each lib will have previous epoch number + dict set epoch pkg epochs $current_e added [dict get $epoch pkg epochs $prev_e added] + 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] + } + if {[dict exists $epoch pkg epochs $prev_e unfound]} { + set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e unfound]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch pkg epochs $prev_e unfound] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch pkg epochs $prev_e unfound_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch pkg epochs $prev_e unfound + } + } errM]} { + puts stderr "epoch_incr_pkg error\n $errM" + } + } + proc epoch_incr_tm {args} { + if {[catch { + upvar ::punk::libunknown::epoch epoch + 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 {[dict exists $epoch tm epochs $prev_e indexes]} { + #bring across the previous indexes records if static filesystem (zipfs) + if {[info commands ::tcl::zipfs::root] ne ""} { + 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]} { + #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] + 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] + } + if {[dict exists $epoch tm epochs $prev_e unfound]} { + set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e unfound]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch tm epochs $prev_e unfound] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch tm epochs $prev_e unfound_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch tm epochs $prev_e unfound + } + + } errM]} { + puts stderr "epoch_incr_tm error\n $errM" + } + } + + proc init {} { + 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 {[namespace origin ::package] eq "::punk::libunknown::package"} { + #This is far from conclusive - there may be other renamers (e.g commandstack) + return + } + if {[info commands ::punk::libunknown::package] ne ""} { + puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]" + return + } + + 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] + foreach p $forgets_requested { + #'package files' not avail in early 8.6 + 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 + } + } + if {[llength $ok_forgets]} { + return [::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 unable to use index $index" + } + return $epochinfo + } else { + error "package epoch {*}$a2 unsupported - expected 'pkg incr' or 'tm incr' or 'pkg ' or 'tm '" + } + } + } + } + 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 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 unimplemented" + } + } + } + } + default { + return [::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]} { + package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} + } + + } + + proc default {} { + package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::libunknown ---}] +} +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# 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.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/punk/packagepreference-999999.0a1.0.tm b/src/modules/punk/packagepreference-999999.0a1.0.tm index a996a851..e3df4b54 100644 --- a/src/modules/punk/packagepreference-999999.0a1.0.tm +++ b/src/modules/punk/packagepreference-999999.0a1.0.tm @@ -174,7 +174,7 @@ tcl::namespace::eval punk::packagepreference { set is_exact 1 } else { set pkg [lindex $args 1] - set vwant [lrange $args 2 end] ;#rare - but version can be a list of options + set vwant [lrange $args 2 end] ;#rare - but version can be a list of requirements if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { #only one version - and it has a dash lassign [split [lindex $vwant 0] -] a b diff --git a/src/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm index 69e5dcc8..0b088300 100644 --- a/src/modules/punk/repl-999999.0a1.0.tm +++ b/src/modules/punk/repl-999999.0a1.0.tm @@ -20,18 +20,54 @@ if {[dict exists $stdin_info -mode]} { #give up for now set tcl_interactive 1 -if {[info commands ::tcl::zipfs::root] ne ""} { - set zr [::tcl::zipfs::root] - if {[file join $zr app modules] in [tcl::tm::list]} { - #todo - better way to find latest version - without package require - set lib [file join $zr app modules punk libunknown.tm] - if {[file exists $lib]} { - source $lib - punk::libunknown::init - #package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown} +#if {[info commands ::tcl::zipfs::root] ne ""} { +# set zr [::tcl::zipfs::root] +# if {[file join $zr app modules] in [tcl::tm::list]} { +# #todo - better way to find latest version - without package require +# set lib [file join $zr app modules punk libunknown.tm] +# if {[file exists $lib]} { +# source $lib +# punk::libunknown::init +# #package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown} +# } +# } +#} +#------------------------------------------------------------------------------------- +if {[package provide punk::libunknown] eq ""} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { + set libunknown_version_sofar $thisver + set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } + } + } + if {$libunknown ne ""} { + source $libunknown + if {[catch {punk::libunknown::init} errM]} { + puts "error initialising punk::libunknown\n$errM" } } +} else { + #This should be reasonably common - a punk shell will generally have libunknown loaded + # but to start a subshell we load punk::repl + #puts stderr "loading repl package - punk::libunknown [package provide punk::libunknown] already loaded" } +#------------------------------------------------------------------------------------- @@ -2689,6 +2725,7 @@ namespace eval repl { %replthread_interp% [list $opt_callback_interp] \ %tmlist% [list [tcl::tm::list]] \ %autopath% [list $::auto_path] \ + %lib_epoch% [list $::punk::libunknown::epoch]\ ] #scriptmap applied at end to satisfy silly editor highlighting. set init_script { @@ -2718,18 +2755,41 @@ namespace eval repl { # } #} #puts stdout "====================" - if {[info commands ::tcl::zipfs::root] ne ""} { - set zr [::tcl::zipfs::root] ;#always ends with / ? - REVIEW - if {[file join $zr app modules] in [tcl::tm::list]} { - #todo - better way to find latest version - without package require - set lib [file join $zr app modules punk libunknown.tm] - if {[file exists $lib]} { - source $lib - punk::libunknown::init - #package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown} + #----------------------------------------------------------------------------- + + namespace eval ::punk::libunknown {} + set ::punk::libunknown::epoch %lib_epoch% + + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { + set libunknown_version_sofar $thisver + set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib } } } + if {$libunknown ne ""} { + source $libunknown + if {[catch {punk::libunknown::init} errM]} { + puts "error initialising punk::libunknown\n$errM" + } + } + #----------------------------------------------------------------------------- + package require punk::packagepreference punk::packagepreference::install @@ -3009,6 +3069,10 @@ namespace eval repl { } punk - 0 { interp create code + code eval [list namespace eval ::punk::libunknown {}] + catch { + code eval [list set ::punk::libunknown::epoch $::punk::libunknown::epoch] + } } punkisland { interp create code @@ -3364,19 +3428,40 @@ namespace eval repl { tcl::tm::add {*}[lreverse %tmlist%] #puts "code interp chan names-->[chan names]" - #ZZZ ZR - if {[info commands ::tcl::zipfs::root] ne ""} { - set zr [::tcl::zipfs::root] ;#always ends with / ? - REVIEW - if {[file join $zr app modules] in [tcl::tm::list]} { - #todo - better way to find latest version - without package require - set lib [file join $zr app modules punk libunknown.tm] - if {[file exists $lib]} { - source $lib - punk::libunknown::init - #package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown} + #----------------------------------------------------------------------------- + if {[package provide punk::libunknown] eq ""} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { + set libunknown_version_sofar $thisver + set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } + } + } + if {$libunknown ne ""} { + source $libunknown + if {[catch {punk::libunknown::init} errM]} { + puts "error initialising punk::libunknown\n$errM" } } + } else { + puts stderr "punk::libunknown [package provide punk::libunknown] already loaded" } + #----------------------------------------------------------------------------- # -- --- #review @@ -3394,7 +3479,7 @@ namespace eval repl { } else { puts stderr "repl code interp loaded vfs,vfs::zip lag:[expr {[clock millis] - $tsstart}]" } - puts stderr "package unknown: [package unknown]" + #puts stderr "package unknown: [package unknown]" #puts stderr ----- #puts stderr [join $::auto_path \n] diff --git a/src/vendormodules/commandstack-0.3.tm b/src/vendormodules/commandstack-0.3.tm index 7884214c..b2561a20 100644 --- a/src/vendormodules/commandstack-0.3.tm +++ b/src/vendormodules/commandstack-0.3.tm @@ -99,8 +99,11 @@ namespace eval commandstack { } } - proc get_stack {command} { + proc get_stack {{command ""}} { variable all_stacks + if {$command eq ""} { + return $all_stacks + } set command [uplevel 1 [list namespace which $command]] if {[dict exists $all_stacks $command]} { return [dict get $all_stacks $command] @@ -116,6 +119,7 @@ namespace eval commandstack { variable all_stacks if {[dict exists $all_stacks $command]} { set stack [dict get $all_stacks $command] + #stack is a list of dicts, 1st entry is token { } set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] if {$posn > -1} { set record [lindex $stack $posn] diff --git a/src/vendormodules/modpod-0.1.3.tm b/src/vendormodules/modpod-0.1.3.tm index 44da4684..540a1696 100644 --- a/src/vendormodules/modpod-0.1.3.tm +++ b/src/vendormodules/modpod-0.1.3.tm @@ -134,12 +134,12 @@ namespace eval modpod { #old tar connect mechanism - review - not needed? proc connect {args} { puts stderr "modpod::connect--->>$args" - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::modpod::connect -type -default "" @values -min 1 -max 1 path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" - } $args] + }] catch { punk::lib::showdict $argd ;#heavy dependencies } @@ -168,7 +168,7 @@ namespace eval modpod { } else { #connect to .tm but may still be unwrapped version available - lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) set this_pkg_tm_folder [file dirname $modpodpath] if {$connected(type,$modpodpath) ne "unwrapped"} { #Not directly connected to unwrapped version - but may still be redirected there @@ -225,11 +225,15 @@ namespace eval modpod { if {$connected(startdata,$modpodpath) >= 0} { #verify we have a valid tar header - if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { + if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} { seek $fh $connected(startdata,$modpodpath) start return [list ok $fh] } else { #error "cannot verify tar header" + #try zipfs + if {[info commands tcl::zipfs::mount] ne ""} { + + } } } lpop connected(to) end @@ -262,11 +266,12 @@ namespace eval modpod { return 1 } proc get {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { + @id -id ::modpod::get -from -default "" -help "path to pod" - *values -min 1 -max 1 + @values -min 1 -max 1 filename - } $args] + }] set frompod [dict get $argd opts -from] set filename [dict get $argd values filename] @@ -329,7 +334,7 @@ namespace eval modpod::lib { #zipfile is a pure zip at this point - ie no script/exe header proc make_zip_modpod {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::modpod::lib::make_zip_modpod -offsettype -default "archive" -choices {archive file} -help\ "Whether zip offsets are relative to start of file or start of zip-data within the file. @@ -340,7 +345,7 @@ namespace eval modpod::lib { @values -min 2 -max 2 zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" - } $args] + }] set zipfile [dict get $argd values zipfile] set outfile [dict get $argd values outfile] set opt_offsettype [dict get $argd opts -offsettype] @@ -359,7 +364,7 @@ namespace eval modpod::lib { set moddir [file dirname $modfile] set mod_and_ver [file rootname [file tail $modfile]] lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver.tm]} { + if {[file exists $moddir/#modpod-$mod_and_ver]} { source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm } else { #determine module namespace so we can mount appropriately diff --git a/src/vfs/_config/modules/punk/libunknown.tm b/src/vfs/_config/modules/punk/libunknown.tm deleted file mode 100644 index 58173834..00000000 --- a/src/vfs/_config/modules/punk/libunknown.tm +++ /dev/null @@ -1,673 +0,0 @@ -# -*- tcl -*- -# module template: shellspy/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.1 -# Meta platform tcl -# Meta license MIT -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin shellspy_module_punk::libunknown 0.1] -#[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] - - variable PUNKARGS - - - variable searchpath_tms [dict create] ;#zipfs is static - #tcl::tm::list may be added to - with non zipfs paths - #package forget may be used - #so we can't avoid rechecking tm paths - #can cache only the tm files in each searchpath - variable searchpath_modules_added [dict create] - - variable searchpath_indexes [dict create] - variable searchpath_packages_added [dict create] - - - - #proc sample1 {p1 n args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 - # #[para] Arguments: - # # [list_begin arguments] - # # [arg_def tring p1] A description of string argument p1. - # # [arg_def integer n] A description of integer argument n. - # # [list_end] - # return "ok" - #} - - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::libunknown ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - - - -tcl::namespace::eval punk::libunknown { - 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." - }] - - - #will use standard mechanism for non zipfs paths in the tm list. - proc zipfs_tm_UnknownHandler {original name args} { - # Import the list of paths to search for packages in module form. - # Import the pattern used to check package names in detail. - variable searchpath_tms - variable searchpath_modules_added - - #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. - - set satisfied 0 - foreach path $paths { - if {![interp issafe] && ![file exists $path]} { - continue - } - set currentsearchpath [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. - - if {[string match [tcl::zipfs::root]* $path]} { - if {[dict exists $searchpath_tms $currentsearchpath]} { - set tmfiles [dict keys [dict get $searchpath_tms $currentsearchpath]] - #puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles ( cached ): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath" - } else { - - if {![interp issafe] && ![file exists $currentsearchpath]} { - continue - } - - #set tmfiles [glob -nocomplain -directory $currentsearchpath *.tm] - #dict set searchpath_tms $currentsearchpath $tmfiles - - dict set searchpath_tms $currentsearchpath [dict create] - - # ################################################################# - set tm_paths [::tcl::zipfs::list $currentsearchpath/*.tm] ;#could theoretically be a dir - this is effectively a tree traversal - #puts "--->zipfs_tm_UnknownHandler llength tm_paths: [llength $tm_paths]" - #process in the order they came - sorting large list more expensive?? review - foreach tm_path $tm_paths { - set loc [file dirname $tm_path] - dict set searchpath_tms $loc $tm_path 1 - } - set tmfiles [dict keys [dict get $searchpath_tms $currentsearchpath]] - #puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles (UNcached): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath" - - # ################################################################# - } - - # like normal processing - but track searchpath_modules_added (for static zipfs) - - set can_skip_update 0 - if {[dict exists $searchpath_modules_added $currentsearchpath]} { - if {![dict exists $searchpath_modules_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_tm_UnknownHandler CAN SKIP orig:$original name:$name args:$args searchpath:$currentsearchpath" - set can_skip_update 1 - } - #if this name is in searchpath_modules_added then we must have done a package forget or it wouldn't come back to package unknown - } - - if {!$can_skip_update} { - 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]" - - #JMN - #store only once for each name, although there may be multiple versions - dict set searchpath_modules_added $currentsearchpath $pkgname 1 - - # 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. - } - } - } - } - - } 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] - } - } - proc zipfs_tclPkgUnknown {name args} { - #puts "-> zipfs_tclPkgUnknown $name $args EXPERIMENTAL" - - variable searchpath_indexes - variable searchpath_packages_added - - global auto_path env - - if {![info exists auto_path]} { - return - } - - set tid [format %-19s -] - catch {set tid [thread::id]} - - # 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. - if {[string match [tcl::zipfs::root]* $dir]} { - set currentsearchpath $dir - if {[dict exists $searchpath_indexes $currentsearchpath]} { - set indexfiles [dict keys [dict get $searchpath_indexes $currentsearchpath]] - #puts stderr "--->zipfs_tclPkgUnknown $tid llength tmfiles ( cached ): [format %4d [llength $indexfiles]] name:$name searchpath:$currentsearchpath" - } else { - dict set searchpath_indexes $currentsearchpath [dict create] - # ################################################################# - set indexpaths [::tcl::zipfs::list $currentsearchpath/*pkgIndex.tcl] ;#'treelike' and returns dirs and files with no way to discern without 'file type' tests - #glob can return xxxpkgIndex.tcl too - still need final check that tail is pkgIndex.tcl - - #puts "--->zipfs_tclPkgUnknown llength indexpaths: [llength $indexpaths]" - set dirlen [string length $currentsearchpath] - #process in the order they came - sorting large list more expensive?? review - foreach idxpath $indexpaths { - if {[file tail $idxpath] ne "pkgIndex.tcl"} { - #strictly, should be a 'file type' test too - continue - } - set tail [string range $idxpath $dirlen+1 end] ;#dirlen is without trailing slash - set tailparts [file split $tail] - if {[llength $tailparts] == 1} { - #dict lappend searchpath_indexes $currentsearchpath $idxpath - dict set searchpath_indexes $currentsearchpath $idxpath 1 - } else { - #standard package search for libs looks 1 down only? - review - #review - set parent [file dirname $idxpath] - set gparent [file dirname $parent] - dict set searchpath_indexes $parent $idxpath 1 - dict set searchpath_indexes $gparent $idxpath 1 - } - } - set indexfiles [dict keys [dict get $searchpath_indexes $currentsearchpath]] - #puts stderr "--->zipfs_tclPkgUnknown $tid llength tmfiles (UNcached): [format %4d [llength $indexfiles]] name:$name searchpath:$currentsearchpath" - # ################################################################# - } - - set can_skip_sourcing 0 - if {[dict exists $searchpath_packages_added $currentsearchpath]} { - if {![dict exists $searchpath_packages_added $currentsearchpath $name]} { - #if {$name ni [dict get $searchpath_packages_added $currentsearchpath]} {} - #$name wasn't provided by this path before - in static zipfs it shouldn't be necessary to look here again. - #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) - #puts stderr "zipfs_tclPkgUnknown CAN SKIP $name currentsearchpath:$currentsearchpath" - set can_skip_sourcing 1 - } - #else - #if this name is in searchpath_packages_added then we must have done a package forget or it wouldn't come back to package unknown ? - } - - set sourced 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' - set before_pkgs [package names] - set before_dict [dict create] - foreach bp $before_pkgs { - dict set before_dict $bp [package versions $bp] - } - catch { - foreach file $indexfiles { - set dir [file dirname $file] - if {![info exists procdDirs($dir)]} { - try { - #puts stderr "----->0 sourcing $file" - ::tcl::Pkg::source $file - incr sourced - } 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 after_pkgs [package names] - set just_added [dict create] - if {[llength $after_pkgs] > [llength $before_pkgs]} { - foreach a $after_pkgs { - if {![dict exists $before_dict $a]} { - dict set just_added $a 1 - dict set searchpath_packages_added $currentsearchpath $a 1 - } - } - #puts stderr ">>>zipfs_tclPkgUnknown added [llength $added_pkgs]" - #puts stderr ">>> [join [lrange $added_pkgs 0 10] \n]..." - } - dict for {bp bpversions} $before_dict { - if {[dict exists $just_added $bp]} { - continue - } - if {[llength $bpversions] != [llength [package versions $bp]]} { - dict set searchpath_packages_added $currentsearchpath $bp 1 - } - } - #puts stderr "zipfs_tclPkgUnknown $tid sourced: $sourced (under path: $currentsearchpath)" - } - - } 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 - } - #puts "zipfs_tclPkgUnknown DONE" - } - - proc init {} { - 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 ::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? - } - } - - proc default {} { - package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} - } -} -# == === === === === === === === === === === === === === === - - -# ----------------------------------------------------------------------------- -# 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.1 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/vfs/_config/punk_main.tcl b/src/vfs/_config/punk_main.tcl index 52530a5b..0e96c893 100644 --- a/src/vfs/_config/punk_main.tcl +++ b/src/vfs/_config/punk_main.tcl @@ -13,9 +13,9 @@ apply { args { set tclmajorv [lindex [split [info tclversion] .] 0] - set has_zipfs [expr {[info commands tcl::zipfs::root] ne ""}] + set has_zipfs [expr {[info commands tcl::zipfs::root] ne ""}] if {$has_zipfs} { - set has_zipfs_attached [expr {[llength [tcl::zipfs::mount]]}] + set has_zipfs_attached [expr {[llength [tcl::zipfs::mount]]}] } else { set has_zipfs_attached 0 } diff --git a/src/vfs/_vfscommon.vfs/lib/xxx/pkgIndex.tcl b/src/vfs/_vfscommon.vfs/lib/xxx/pkgIndex.tcl new file mode 100644 index 00000000..6e9e560e --- /dev/null +++ b/src/vfs/_vfscommon.vfs/lib/xxx/pkgIndex.tcl @@ -0,0 +1,5 @@ +if {![package vsatisfies [package provide Tcl] 8.5 9]} { + # PRAGMA: returnok + return +} +package ifneeded xxx 0.1.3 [list source [file join $dir xxx-0.1.3.tm]] diff --git a/src/vfs/_vfscommon.vfs/lib/xxx/xxx-0.1.3.tm b/src/vfs/_vfscommon.vfs/lib/xxx/xxx-0.1.3.tm new file mode 100644 index 00000000..f7c46dc2 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/lib/xxx/xxx-0.1.3.tm @@ -0,0 +1,50 @@ +# -*- tcl -*- +# +# 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) 2023 +# +# @@ Meta Begin +# Application xxx 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval xxx { + + + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide xxx [namespace eval xxx { + variable version + set version 0.1.3 +}] +return \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm b/src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm index 7884214c..b2561a20 100644 --- a/src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm @@ -99,8 +99,11 @@ namespace eval commandstack { } } - proc get_stack {command} { + proc get_stack {{command ""}} { variable all_stacks + if {$command eq ""} { + return $all_stacks + } set command [uplevel 1 [list namespace which $command]] if {[dict exists $all_stacks $command]} { return [dict get $all_stacks $command] @@ -116,6 +119,7 @@ namespace eval commandstack { variable all_stacks if {[dict exists $all_stacks $command]} { set stack [dict get $all_stacks $command] + #stack is a list of dicts, 1st entry is token { } set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] if {$posn > -1} { set record [lindex $stack $posn] diff --git a/src/vfs/_vfscommon.vfs/modules/modpod-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/modpod-0.1.3.tm index 44da4684..540a1696 100644 --- a/src/vfs/_vfscommon.vfs/modules/modpod-0.1.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/modpod-0.1.3.tm @@ -134,12 +134,12 @@ namespace eval modpod { #old tar connect mechanism - review - not needed? proc connect {args} { puts stderr "modpod::connect--->>$args" - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::modpod::connect -type -default "" @values -min 1 -max 1 path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" - } $args] + }] catch { punk::lib::showdict $argd ;#heavy dependencies } @@ -168,7 +168,7 @@ namespace eval modpod { } else { #connect to .tm but may still be unwrapped version available - lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) set this_pkg_tm_folder [file dirname $modpodpath] if {$connected(type,$modpodpath) ne "unwrapped"} { #Not directly connected to unwrapped version - but may still be redirected there @@ -225,11 +225,15 @@ namespace eval modpod { if {$connected(startdata,$modpodpath) >= 0} { #verify we have a valid tar header - if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { + if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} { seek $fh $connected(startdata,$modpodpath) start return [list ok $fh] } else { #error "cannot verify tar header" + #try zipfs + if {[info commands tcl::zipfs::mount] ne ""} { + + } } } lpop connected(to) end @@ -262,11 +266,12 @@ namespace eval modpod { return 1 } proc get {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { + @id -id ::modpod::get -from -default "" -help "path to pod" - *values -min 1 -max 1 + @values -min 1 -max 1 filename - } $args] + }] set frompod [dict get $argd opts -from] set filename [dict get $argd values filename] @@ -329,7 +334,7 @@ namespace eval modpod::lib { #zipfile is a pure zip at this point - ie no script/exe header proc make_zip_modpod {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::modpod::lib::make_zip_modpod -offsettype -default "archive" -choices {archive file} -help\ "Whether zip offsets are relative to start of file or start of zip-data within the file. @@ -340,7 +345,7 @@ namespace eval modpod::lib { @values -min 2 -max 2 zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" - } $args] + }] set zipfile [dict get $argd values zipfile] set outfile [dict get $argd values outfile] set opt_offsettype [dict get $argd opts -offsettype] @@ -359,7 +364,7 @@ namespace eval modpod::lib { set moddir [file dirname $modfile] set mod_and_ver [file rootname [file tail $modfile]] lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver.tm]} { + if {[file exists $moddir/#modpod-$mod_and_ver]} { source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm } else { #determine module namespace so we can mount appropriately diff --git a/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm new file mode 100644 index 00000000..24e2abc7 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm @@ -0,0 +1,1039 @@ +# -*- tcl -*- +# module template: shellspy/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.1 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::libunknown 0.1] +#[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 + if {![info exists epoch]} { + set tmstate [dict create 0 {}] + set pkgstate [dict create 0 {}] + set tminfo [dict create current 0 epochs $tmstate] + set pkginfo [dict create current 0 epochs $pkgstate] + + set epoch [dict create tm $tminfo pkg $pkginfo] + } + + 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 + proc tcl_Pkg_source {filename} { + uplevel 1 [list ::source $filename] + } + } + + #will use standard mechanism for non zipfs paths in the tm list. + proc zipfs_tm_UnknownHandler {original name args} { + # 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] + + + #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 [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 {[dict exists $epoch tm epochs $pkg_epoch indexes $currentsearchpath]} { + #indexes are actual .tm files here + set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $currentsearchpath]] + #puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles ( cached ): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath" + } else { + + if {![interp issafe] && ![file exists $currentsearchpath]} { + dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath [dict create] + continue + } + + + dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath [dict create] + + # ################################################################# + if {$has_zipfs && [string match $zipfsroot* $path]} { + 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 currentsearchpath + set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $currentsearchpath]] + } else { + set tmfiles [glob -nocomplain -directory $currentsearchpath *.tm] + foreach tm_path $tmfiles { + dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath $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 $currentsearchpath]} { + if {![dict exists $epoch tm 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_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 + } + } + } else { + #dynamic - can only skip if negatively cached for the current epoch + if {[dict exists $epoch tm epochs $pkg_epoch unfound $currentsearchpath $name]} { + #puts stderr "zipfs_tm_UnknownHandler $tid CAN SKIP $name currentsearchpath:$currentsearchpath (unfound already in epoch $pkg_epoch)" + set can_skip_update 1 + } + + } + + if {!$can_skip_update} { + set strip [llength [file split $path]] + set found_name_in_currentsearchpath 0 ;#for negative cache by epoch + 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]" + + #JMN + #store only once for each name, although there may be multiple versions + dict set epoch tm epochs $pkg_epoch added $currentsearchpath $pkgname $pkg_epoch + + # 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 + } + } + } + if {!$found_name_in_currentsearchpath} { + #can record as unfound for this path - for this epoch + dict set epoch tm epochs $pkg_epoch unfound $currentsearchpath $name 1 + } + } + + } 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] + } + } + proc zipfs_tclPkgUnknown {name args} { + #puts "-> zipfs_tclPkgUnknown $name $args EXPERIMENTAL" + + variable epoch + set pkg_epoch [dict get $epoch pkg current] + + + #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 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] + + + # 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 {[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 + #can avoid scan if added via this path in any epoch + 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 + } + } + } else { + #dynamic auto_path dirs - libs could have been added/removed + #scan unless cached negative for this epoch + if {[dict exists $epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name]} { + #puts stderr "zipfs_tclPkgUnknown $tid CAN SKIP $name currentsearchpath:$currentsearchpath (unfound already in epoch $pkg_epoch)" + set can_skip_sourcing 1 + } + } + #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 + 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? worth it? + if {![info exists before_pkgs]} { + set before_pkgs [package names] + } + #update the before_dict which persists across while loop + foreach bp $before_pkgs { + dict set before_dict $bp [package versions $bp] + } + catch { + foreach file $indexfiles { + set dir [file dirname $file] + if {![info exists procdDirs($dir)]} { + try { + #puts stderr "----->0 sourcing $file" + incr sourced ;#count as sourced even if source fails; keep before actual source action + #::tcl::Pkg::source $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" + incr sourced + #::tcl::Pkg::source $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 + } + } + } + #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] + set just_added [dict create] + if {[llength $after_pkgs] > [llength $before_pkgs]} { + foreach a $after_pkgs { + if {![dict exists $before_dict $a]} { + dict set just_added $a 1 + dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a $pkg_epoch + } + } + #puts stderr ">>>zipfs_tclPkgUnknown added [llength $added_pkgs]" + #puts stderr ">>> [join [lrange $added_pkgs 0 10] \n]..." + } + dict for {bp bpversions} $before_dict { + if {[dict exists $just_added $bp]} { + continue + } + if {[llength $bpversions] != [llength [package versions $bp]]} { + dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp $pkg_epoch + } + } + #puts stderr "zipfs_tclPkgUnknown $tid sourced: $sourced (under path: $currentsearchpath)" + if {$name ni $after_pkgs} { + #cache negative result (for this epoch only) + dict set epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name 1 + } elseif {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} { + dict set epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name 1 + } + + lappend before_pkgs {*}[dict keys $just_added] + } + } + + } 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 + } + #puts "zipfs_tclPkgUnknown DONE" + } + proc epoch_incr_pkg {args} { + if {[catch { + global auto_path + upvar ::punk::libunknown::epoch epoch + set prev_e [dict get $epoch pkg current] + set current_e [expr {$prev_e + 1}] + dict set epoch pkg current $current_e + dict set epoch pkg epochs $current_e [dict create] + if {[dict exists $epoch pkg epochs $prev_e indexes]} { + #bring across the previous indexes records if static filesystem (zipfs) + if {[info commands ::tcl::zipfs::root] ne ""} { + 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 + } + } + } + } + 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]} { + #bring across - each lib will have previous epoch number + dict set epoch pkg epochs $current_e added [dict get $epoch pkg epochs $prev_e added] + 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] + } + if {[dict exists $epoch pkg epochs $prev_e unfound]} { + set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e unfound]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch pkg epochs $prev_e unfound] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch pkg epochs $prev_e unfound_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch pkg epochs $prev_e unfound + } + } errM]} { + puts stderr "epoch_incr_pkg error\n $errM" + } + } + proc epoch_incr_tm {args} { + if {[catch { + upvar ::punk::libunknown::epoch epoch + 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 {[dict exists $epoch tm epochs $prev_e indexes]} { + #bring across the previous indexes records if static filesystem (zipfs) + if {[info commands ::tcl::zipfs::root] ne ""} { + 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]} { + #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] + 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] + } + if {[dict exists $epoch tm epochs $prev_e unfound]} { + set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e unfound]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch tm epochs $prev_e unfound] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch tm epochs $prev_e unfound_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch tm epochs $prev_e unfound + } + + } errM]} { + puts stderr "epoch_incr_tm error\n $errM" + } + } + + proc init {} { + 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 {[namespace origin ::package] eq "::punk::libunknown::package"} { + #This is far from conclusive - there may be other renamers (e.g commandstack) + return + } + if {[info commands ::punk::libunknown::package] ne ""} { + puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]" + return + } + + 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] + foreach p $forgets_requested { + #'package files' not avail in early 8.6 + 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 + } + } + if {[llength $ok_forgets]} { + return [::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 unable to use index $index" + } + return $epochinfo + } else { + error "package epoch {*}$a2 unsupported - expected 'pkg incr' or 'tm incr' or 'pkg ' or 'tm '" + } + } + } + } + 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 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 unimplemented" + } + } + } + } + default { + return [::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]} { + package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} + } + + } + + proc default {} { + package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::libunknown ---}] +} +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# 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.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm index d823a923..317fc9de 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm @@ -174,7 +174,7 @@ tcl::namespace::eval punk::packagepreference { set is_exact 1 } else { set pkg [lindex $args 1] - set vwant [lrange $args 2 end] ;#rare - but version can be a list of options + set vwant [lrange $args 2 end] ;#rare - but version can be a list of requirements if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { #only one version - and it has a dash lassign [split [lindex $vwant 0] -] a b diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm index 26f92ae5..a36d5180 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm @@ -20,18 +20,54 @@ if {[dict exists $stdin_info -mode]} { #give up for now set tcl_interactive 1 -if {[info commands ::tcl::zipfs::root] ne ""} { - set zr [::tcl::zipfs::root] - if {[file join $zr app modules] in [tcl::tm::list]} { - #todo - better way to find latest version - without package require - set lib [file join $zr app modules punk libunknown.tm] - if {[file exists $lib]} { - source $lib - punk::libunknown::init - #package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown} +#if {[info commands ::tcl::zipfs::root] ne ""} { +# set zr [::tcl::zipfs::root] +# if {[file join $zr app modules] in [tcl::tm::list]} { +# #todo - better way to find latest version - without package require +# set lib [file join $zr app modules punk libunknown.tm] +# if {[file exists $lib]} { +# source $lib +# punk::libunknown::init +# #package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown} +# } +# } +#} +#------------------------------------------------------------------------------------- +if {[package provide punk::libunknown] eq ""} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { + set libunknown_version_sofar $thisver + set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } + } + } + if {$libunknown ne ""} { + source $libunknown + if {[catch {punk::libunknown::init} errM]} { + puts "error initialising punk::libunknown\n$errM" } } +} else { + #This should be reasonably common - a punk shell will generally have libunknown loaded + # but to start a subshell we load punk::repl + #puts stderr "loading repl package - punk::libunknown [package provide punk::libunknown] already loaded" } +#------------------------------------------------------------------------------------- @@ -2689,6 +2725,7 @@ namespace eval repl { %replthread_interp% [list $opt_callback_interp] \ %tmlist% [list [tcl::tm::list]] \ %autopath% [list $::auto_path] \ + %lib_epoch% [list $::punk::libunknown::epoch]\ ] #scriptmap applied at end to satisfy silly editor highlighting. set init_script { @@ -2718,18 +2755,41 @@ namespace eval repl { # } #} #puts stdout "====================" - if {[info commands ::tcl::zipfs::root] ne ""} { - set zr [::tcl::zipfs::root] ;#always ends with / ? - REVIEW - if {[file join $zr app modules] in [tcl::tm::list]} { - #todo - better way to find latest version - without package require - set lib [file join $zr app modules punk libunknown.tm] - if {[file exists $lib]} { - source $lib - punk::libunknown::init - #package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown} + #----------------------------------------------------------------------------- + + namespace eval ::punk::libunknown {} + set ::punk::libunknown::epoch %lib_epoch% + + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { + set libunknown_version_sofar $thisver + set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib } } } + if {$libunknown ne ""} { + source $libunknown + if {[catch {punk::libunknown::init} errM]} { + puts "error initialising punk::libunknown\n$errM" + } + } + #----------------------------------------------------------------------------- + package require punk::packagepreference punk::packagepreference::install @@ -3009,6 +3069,10 @@ namespace eval repl { } punk - 0 { interp create code + code eval [list namespace eval ::punk::libunknown {}] + catch { + code eval [list set ::punk::libunknown::epoch $::punk::libunknown::epoch] + } } punkisland { interp create code @@ -3364,19 +3428,40 @@ namespace eval repl { tcl::tm::add {*}[lreverse %tmlist%] #puts "code interp chan names-->[chan names]" - #ZZZ ZR - if {[info commands ::tcl::zipfs::root] ne ""} { - set zr [::tcl::zipfs::root] ;#always ends with / ? - REVIEW - if {[file join $zr app modules] in [tcl::tm::list]} { - #todo - better way to find latest version - without package require - set lib [file join $zr app modules punk libunknown.tm] - if {[file exists $lib]} { - source $lib - punk::libunknown::init - #package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown} + #----------------------------------------------------------------------------- + if {[package provide punk::libunknown] eq ""} { + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { + set libunknown_version_sofar $thisver + set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } + } + } + if {$libunknown ne ""} { + source $libunknown + if {[catch {punk::libunknown::init} errM]} { + puts "error initialising punk::libunknown\n$errM" } } + } else { + puts stderr "punk::libunknown [package provide punk::libunknown] already loaded" } + #----------------------------------------------------------------------------- # -- --- #review @@ -3394,7 +3479,7 @@ namespace eval repl { } else { puts stderr "repl code interp loaded vfs,vfs::zip lag:[expr {[clock millis] - $tsstart}]" } - puts stderr "package unknown: [package unknown]" + #puts stderr "package unknown: [package unknown]" #puts stderr ----- #puts stderr [join $::auto_path \n] diff --git a/src/vfs/_vfscommon.vfs/modules/xxx-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/xxx-0.1.2.tm new file mode 100644 index 00000000..00e8eb13 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/xxx-0.1.2.tm @@ -0,0 +1,50 @@ +# -*- tcl -*- +# +# 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) 2023 +# +# @@ Meta Begin +# Application xxx 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval xxx { + + + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide xxx [namespace eval xxx { + variable version + set version 0.1.2 +}] +return \ No newline at end of file diff --git a/src/vfs/punk9win.vfs/modules/punk/libunknown.tm#..+_config+modules+punk+libunknown.tm#@punk%3a%3aboot,merge_over#.fxlnk b/src/vfs/punk9win.vfs/modules/punk/libunknown.tm#..+_config+modules+punk+libunknown.tm#@punk%3a%3aboot,merge_over#.fxlnk deleted file mode 100644 index e69de29b..00000000