jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
315 Commits
1 Branch
1 Tag
199 MiB
 
 
 
 
 
 
Tree: f65d8f7c02
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'f65d8f7c02'
${ noResults }
punkshell/src/vfs/_config/modules/punk/libunknown.tm

673 lines
32 KiB
Raw Blame History

# -*- 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]