diff --git a/scriptlib/encoding.tcl b/scriptlib/encoding.tcl new file mode 100644 index 00000000..990ae8b8 --- /dev/null +++ b/scriptlib/encoding.tcl @@ -0,0 +1,46 @@ +set existing_enc [encoding system] +#Any "puts" before setting 'encoding system' will set the existing system encoding on the channel (others too, but depending if console vs piped) +#e.g +### puts stderr test +#Uncommenting the above will mean that both stdout and stderr (when in a piped-situation, ie no console) are initialised to existing_enc - not the one we set below! +set arg_setencoding [lindex $::argv 0] +if {$arg_setencoding ne ""} { + if {$arg_setencoding ni [encoding names]} { + puts stderr "Usage: encoding.tcl ?tcl_encoding?" + puts stderr "(Note difference in stdout/stderr encodings when piped: e.g encoding.tcl cp437 | cat)" + puts stderr "encoding names:\n" + puts stderr "[encoding names]" + exit 1 + } + encoding system $arg_setencoding +} else { + encoding system utf-8 +} +puts "original encoding system : $existing_enc" +puts "configured encoding system: [encoding system]" +puts "stdout: [chan conf stdout]" +puts "stderr: [chan conf stderr]" +puts "[lindex $::argv 0]" + +#compare: +#1) both stderr and stdout are to console - not affected by changed system encoding +#>tclsh encoding.tcl +# original encoding system : utf-8 +# configured encoding system: utf-8 +# stdout: -blocking 1 -buffering line -buffersize 4096 -encoding utf-16 -eofchar {} -profile tcl8 -translation crlf -winsize {224 57} +# stderr: -blocking 1 -buffering none -buffersize 4096 -encoding utf-16 -eofchar {} -profile tcl8 -translation crlf -winsize {224 57} + +#2) stdout not going to console +#>tclsh encoding.tcl | cat +# original encoding system : utf-8 +# configured encoding system: utf-8 +# stdout: -blocking 1 -buffering line -buffersize 4096 -encoding utf-8 -eofchar {} -profile tcl8 -translation crlf +# stderr: -blocking 1 -buffering none -buffersize 4096 -encoding utf-16 -eofchar {} -profile tcl8 -translation crlf -winsize {224 57} + +#3) neither channel to console +#>tclsh encoding.tcl |& cat +# original encoding system : utf-8 +# configured encoding system: utf-8 +# stdout: -blocking 1 -buffering line -buffersize 4096 -encoding utf-8 -eofchar {} -profile tcl8 -translation crlf +# stderr: -blocking 1 -buffering none -buffersize 4096 -encoding utf-8 -eofchar {} -profile tcl8 -translation crlf + diff --git a/scriptlib/requiremath.tcl b/scriptlib/requiremath.tcl new file mode 100644 index 00000000..b3a6eb46 --- /dev/null +++ b/scriptlib/requiremath.tcl @@ -0,0 +1,37 @@ +# used to test execution time of different systems. +# punkshell in zipfs becomes comparable in runtime when a largish number of packages are loaded as below. (some largish in size such as snit) +# if punkshell has punk::libunknown enhancement (faster nonexistant package) +# when there are package requires for nonexistant packages - it is somewhat faster than standard tclsh scanning real filesystem auto_path and tcl::tm::path. + +package require math::decimal +package require math::trig +package require math::bigfloat +package require math::bignum +package require math::fourier +package require math::filters +package require math::complexnumbers +package require math::statistics +package require math::exact +package require math::geometry +package require math::optimize +package require math::calculus +package require math::numtheory +package require math::polynomials + +package require units +package require struct::graph +package require struct::matrix +package require struct::tree +package require struct::list +package require struct::record + +#package require punk::ansi + +package require snit +package require fileutil::magic::filetype + +catch {package require math::nonexistant} +#catch {package require frobnozzle} + + +exit 0 diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index fcbf6ada..f671311f 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -3398,6 +3398,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu -fullcodemerge -type boolean -default 0 -help\ "experimental" -overridecodes -type list -default {} + -rawoverrides -type ansi -default "" @values -min 1 -max 1 text -type string -help\ "String to wrap with ANSI (SGR)" @@ -3418,6 +3419,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rawresets "" set fullmerge 0 set overrides "" + set rawoverrides "" } else { set argd [punk::args::parse $args withid ::punk::ansi::ansiwrap] lassign [dict values $argd] leaders opts values received solos @@ -3428,6 +3430,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rawresets [dict get $opts -rawresets] set fullmerge [dict get $opts -fullcodemerge] set overrides [punk::ansi::ta::get_codes_single [a+ {*}[dict get $opts -overridecodes]]] + set rawoverrides [punk::ansi::ta::get_codes_single [dict get $opts -rawoverrides]] } #note that the result of any sgr_merge or sgr_merge_singles is not necessarily a single Ansi escape sequence. @@ -3450,6 +3453,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set R [punk::ansi::codetype::sgr_merge_singles [list $R {*}$rawresetcodes]] } } + if {$rawoverrides ne ""} { + set rawoverridecodes [punk::ansi::ta::get_codes_single $rawoverrides] + set overrides [list {*}$overrides {*}$rawoverridecodes] + } set codestack [list] if {[punk::ansi::ta::detect $text]} { diff --git a/src/bootsupport/modules/punk/config-0.1.tm b/src/bootsupport/modules/punk/config-0.1.tm index f2f85349..e278d99f 100644 --- a/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/bootsupport/modules/punk/config-0.1.tm @@ -372,8 +372,10 @@ tcl::namespace::eval punk::config { set config_home [dict get $configdata startup xdg_config_home] if {![file exists $config_home]} { - puts stderr "punk::config::init creating punk shell config dir: [dir]" - puts stderr "(todo)" + puts stderr "punk::config::init creating punk shell config dir: $config_home" + if {[catch {file mkdir $config_home} errM]} { + puts stderr "punk::config::init failed to create dir at $config_home\n$errM" + } } set configset [dict get $configdata defaults configset] diff --git a/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm index b964d228..5e12b9a2 100644 --- a/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -50,7 +50,9 @@ namespace eval punk::mix::commandset::loadedlib { set opt_return [dict get $opts -return] set opt_highlight [dict get $opts -highlight] + #REVIEW - this doesn't result in full scans catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + if {[catch {package require natsort}]} { set has_natsort 0 } else { @@ -191,7 +193,7 @@ namespace eval punk::mix::commandset::loadedlib { } else { set has_natsort 1 } - catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + catch {package require $libname 1-0} ;#ensure pkg system has loaded/searched - using unsatisfiable version range set pkgsknown [package names] if {[set posn [lsearch $pkgsknown $libname]] >= 0} { puts stdout "Found package [lindex $pkgsknown $posn]" @@ -237,7 +239,7 @@ namespace eval punk::mix::commandset::loadedlib { set has_natsort 1 } - catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + catch {package require $library 1-0} ;#ensure pkg system has loaded/searched for everything for the path of the specified library (using unsatisfiable version range) if {[file pathtype $modulefoldername] eq "absolute"} { if {![file exists $modulefoldername]} { diff --git a/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/bootsupport/modules/punk/packagepreference-0.1.0.tm index 254c90bf..d823a923 100644 --- a/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/bootsupport/modules/punk/packagepreference-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::packagepreference 0 0.1.0] #[copyright "2024"] #[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] -#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] +#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] #[require punk::packagepreference] #[keywords module package] #[description] @@ -106,7 +106,7 @@ tcl::namespace::eval punk::packagepreference { #*** !doctools #[subsection {Namespace punk::packagepreference}] - #[para] Core API functions for punk::packagepreference + #[para] Core API functions for punk::packagepreference #[list_begin definitions] lappend PUNKARGS [list { @@ -132,7 +132,7 @@ tcl::namespace::eval punk::packagepreference { proc install {} { #*** !doctools #[call [fun install]] - #[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules + #[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules #[para](todo - check info loaded and restrict to existing version as determined from dll/so?) #[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase. #[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names" @@ -155,7 +155,7 @@ tcl::namespace::eval punk::packagepreference { #We can't provide a modernised .tm package for an old package that is commonly used with uppercase letters, in both the old form and lowercased form from a single .tm file. #It could be done by providing a redirecting .tm in a separate module path, or by providing a packageIndex.tcl to redirect it but both these solutions are error prone from a sysops perspective. set stackrecord [commandstack::rename_command -renamer punk::packagepreference package {args} { - #::package override installed by punk::packagepreference::install + #::package override installed by punk::packagepreference::install #return to previous 'package' implementation with: punk::packagepreference::uninstall #uglier but faster than tcl::prefix::match in this instance @@ -176,7 +176,7 @@ tcl::namespace::eval punk::packagepreference { set pkg [lindex $args 1] set vwant [lrange $args 2 end] ;#rare - but version can be a list of options if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { - #only one version - and it has a dash + #only one version - and it has a dash lassign [split [lindex $vwant 0] -] a b if {$a eq $b} { #string compare version nums (can contain dots and a|b) @@ -185,7 +185,7 @@ tcl::namespace::eval punk::packagepreference { } } if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} { - #although we could shortcircuit using vsatisfies to return the ver + #although we could shortcircuit using vsatisfies to return the ver #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. #e.g a package require logger further down the commandstack return [$COMMANDSTACKNEXT {*}$args] @@ -196,13 +196,13 @@ tcl::namespace::eval punk::packagepreference { set available_versions [$COMMANDSTACKNEXT_ORIGINAL versions $pkg] if {[llength $available_versions] > 1} { # --------------------------------------------------------------- - #An attempt to detect dll/so loaded and try to load same version + #An attempt to detect dll/so loaded and try to load same version #dll/so files are often named with version numbers that don't contain dots or a version number at all - #e.g sqlite3400.dll Thread288.dll + #e.g sqlite3400.dll Thread288.dll set pkgloadedinfo [lsearch -nocase -inline -index 1 [info loaded] $pkg] if {[llength $pkgloadedinfo]} { - puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available" + puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available" lassign $pkgloadedinfo path name set lcpath [string tolower $path] #first attempt to find a match for our loaded sharedlib path in a *simple* package ifneeded statement. @@ -219,7 +219,7 @@ tcl::namespace::eval punk::packagepreference { if {[dict exists $lcpath_to_version $lcpath]} { set lversion [dict get $lcpath_to_version $lcpath] - } else { + } else { #fallback to a best effort guess based on the path set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $path $pkg] } @@ -271,13 +271,13 @@ tcl::namespace::eval punk::packagepreference { #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[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" + # return "ok" #} @@ -296,14 +296,14 @@ tcl::namespace::eval punk::packagepreference::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::packagepreference::lib}] - #[para] Secondary functions that are part of the API + #[para] Secondary functions that are part of the API #[list_begin definitions] #proc utility1 {p1 args} { # #*** !doctools # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 + # #[para]Description of utility1 + # return 1 #} @@ -321,7 +321,7 @@ tcl::namespace::eval punk::packagepreference::lib { tcl::namespace::eval punk::packagepreference::system { #*** !doctools #[subsection {Namespace punk::packagepreference::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API variable PUNKARGS lappend PUNKARGS [list { @@ -330,8 +330,8 @@ tcl::namespace::eval punk::packagepreference::system { "Assistance function to determine pkg version from the information obtained from [info loaded]. This is used to try to avoid loading a different version of a binary package in another thread/interp when the package isn't - present in the interp, but [info loaded] indicates the binary is already loaded. - The more general/robust way to avoid this is to ensure ::auto_path and + present in the interp, but [info loaded] indicates the binary is already loaded. + The more general/robust way to avoid this is to ensure ::auto_path and tcl::tm::list are the same in each interp/thread. This call should only be used as a fallback in case a binary package has a more @@ -348,8 +348,8 @@ tcl::namespace::eval punk::packagepreference::system { The filename itself is first checked for a version number - but the number is ignored if it doesn't contain any dots. (prefix is checked to match with $pkgname, with a possible additional prefix - of lib or tcl) - Often (even usually) the parent or grandparent folder will be named as + of lib or tcl) + Often (even usually) the parent or grandparent folder will be named as per the package name with a proper version. If so we can return it, otherwise return empty string. The parent/grandparent matching will be done by looking for a case @@ -395,7 +395,7 @@ tcl::namespace::eval punk::packagepreference::system { } } #review - sometimes path and lib are named only for major.minor but package provides major.minor.subversion - #using returned val to attempt to package require -exact major.minor will fail to load major.minor.subversion + #using returned val to attempt to package require -exact major.minor will fail to load major.minor.subversion return "" } @@ -407,11 +407,11 @@ namespace eval ::punk::args::register { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { variable pkg punk::packagepreference variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/bootsupport/modules/punk/path-0.1.0.tm b/src/bootsupport/modules/punk/path-0.1.0.tm index 1ddd56b7..ff48fcb0 100644 --- a/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/bootsupport/modules/punk/path-0.1.0.tm @@ -703,6 +703,11 @@ namespace eval punk::path { set opt_dir [dict get $opts -directory] } + #comment out to compare timings with treefilenames_zipfs + if {[string match //zipfs:/* $opt_dir]} { + return [treefilenames_zipfs {*}$args] + } + set skip 0 foreach anti $opt_antiglob_paths { if {[globmatchpath $anti $opt_dir]} { @@ -762,6 +767,138 @@ namespace eval punk::path { } return $files } + proc treefilenames_zipfs {args} { + #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW + # is sort order the same? + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + lassign [dict values $argd] leaders opts values received + set tailglobs [dict get $values tailglobs] + # -- --- --- --- --- --- --- + set opt_antiglob_paths [dict get $opts -antiglob_paths] + set opt_antiglob_files [dict get $opts -antiglob_files] + set CALLDEPTH [dict get $opts -call-depth-internal] + # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- + + set files [list] + if {$CALLDEPTH == 0} { + #set opts [dict merge $opts [list -directory $opt_dir]] + if {![dict exists $received -directory]} { + set opt_dir [pwd] + } else { + set opt_dir [dict get $opts -directory] + } + if {![file isdirectory $opt_dir]} { + return [list] + } + } else { + #assume/require to exist in any recursive call + set opt_dir [dict get $opts -directory] + } + if {![string match [zipfs root]* $opt_dir]} { + error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" + } + set dir [string trimright $opt_dir "/"] ;#e.g normalize //zipfs:/x/ to //zipfs:/x + set dirlen [string length $dir] + + set skip 0 + foreach anti $opt_antiglob_paths { + if {[globmatchpath $anti $dir]} { + set skip 1 + break + } + } + if {$skip} { + return [list] + } + set subpaths [zipfs list $dir/*] + set dirlist [list] + set skipdirs [list] + set filelist [list] + #process in the order they came - sorting large list more expensive?? review + foreach sub $subpaths { + set tail [string range $sub $dirlen+1 end] ;#dirlen is without trailing slash + set tailparts [file split $tail] + set accum "" + set skipdir 0 + foreach tp [lrange $tailparts 0 end-1] { + append accum "/$tp" + set superpath "${dir}${accum}" + if {$superpath in $skipdirs} { + #subpart already in skipdirs + set skipdir 1 + break + } + if {$superpath ni $dirlist} { + set skip2 0 + foreach anti $opt_antiglob_paths { + if {[globmatchpath $anti $superpath]} { + set skip2 1 + lappend skipdirs $superpath + break + } + } + if {!$skip2} { + lappend dirlist $superpath + } else { + set skipdir 1 + break + } + } + } + if {!$skipdir} { + #process final part of path + append accum "/[lindex $tailparts end]" + set finalpart "${dir}${accum}" + if {$finalpart ni $dirlist} { + if {[file type $finalpart] eq "file"} { + set ftail [lindex $tailparts end] + set match 0 + if {"*" ni $tailglobs} { + foreach tg $tailglobs { + if {[string match $tg $ftail]} { + set match 1 + break + } + } + } else { + set match 1 + } + if {$match} { + if {[llength $opt_antiglob_files]} { + set skipfile 0 + foreach anti $opt_antiglob_files { + if {[string match $anti $ftail]} { + set skipfile 1; break + } + } + if {!$skipfile} { + lappend filelist $finalpart + } + } else { + lappend filelist $finalpart + } + } + } else { + if {$finalpart ni $dirlist} { + set skip2 0 + foreach anti $opt_antiglob_paths { + if {[globmatchpath $anti $finalpart]} { + set skip2 1 + lappend skipdirs $finalpart + break + } + } + if {!$skip2} { + lappend dirlist $finalpart + } + } + } + } + } + } + return $filelist + } #maint warning - also in punkcheck proc relative {reference location} { diff --git a/src/make.tcl b/src/make.tcl index 775335c3..9809dc62 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -2254,11 +2254,11 @@ proc merge_over {sourcedir targetdir {depth 0}} { set name [dict get $linkinfo name] ;#name the linked file will become set aliased_file_or_dir [file join [file dirname $file_or_dir] $name] set relpath [fileutil::stripPath $sourcedir $aliased_file_or_dir] - set target [file join $targetdir $relpath] + set target [file join $targetdir $relpath] if {[file type $actualsource] eq "file"} { - #fauxlink linktarget (source data) is a file + #fauxlink linktarget (source data) is a file puts -nonewline stdout "\x1b\[32m\x1b\[m" - #puts "file copy -force $actualsource $target" + puts "file copy -force $actualsource $target" file copy -force $actualsource $target } else { #fauxlink linktarget (source data) is a folder @@ -2409,7 +2409,7 @@ foreach vfstail $vfs_tails { #e.g ../vfs/punk87.vfs {cksum xxxx cksum_all_opts {-cksum_content 1 ... -cksum_algorithm sha1}} dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/$vfstail] } - $vfs_event targetset_cksumcache_set $path_cksum_cache ;#cached cksum entries for .vfs folder + $vfs_event targetset_cksumcache_set $path_cksum_cache ;#cached cksum entries for .vfs folder $vfs_event targetset_addsource $sourcefolder/vfs/_config ;#some files linked via fauxlink - need to detect change $vfs_event targetset_addsource $sourcefolder/vfs/_vfscommon.vfs $vfs_event targetset_addsource $sourcefolder/vfs/$vfstail diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index ccfa009c..f2e08635 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -3398,6 +3398,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu -fullcodemerge -type boolean -default 0 -help\ "experimental" -overridecodes -type list -default {} + -rawoverrides -type ansi -default "" @values -min 1 -max 1 text -type string -help\ "String to wrap with ANSI (SGR)" @@ -3418,6 +3419,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rawresets "" set fullmerge 0 set overrides "" + set rawoverrides "" } else { set argd [punk::args::parse $args withid ::punk::ansi::ansiwrap] lassign [dict values $argd] leaders opts values received solos @@ -3428,6 +3430,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rawresets [dict get $opts -rawresets] set fullmerge [dict get $opts -fullcodemerge] set overrides [punk::ansi::ta::get_codes_single [a+ {*}[dict get $opts -overridecodes]]] + set rawoverrides [punk::ansi::ta::get_codes_single [dict get $opts -rawoverrides]] } #note that the result of any sgr_merge or sgr_merge_singles is not necessarily a single Ansi escape sequence. @@ -3450,6 +3453,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set R [punk::ansi::codetype::sgr_merge_singles [list $R {*}$rawresetcodes]] } } + if {$rawoverrides ne ""} { + set rawoverridecodes [punk::ansi::ta::get_codes_single $rawoverrides] + set overrides [list {*}$overrides {*}$rawoverridecodes] + } set codestack [list] if {[punk::ansi::ta::detect $text]} { diff --git a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm index 193a0202..9af513b4 100644 --- a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm @@ -50,7 +50,9 @@ namespace eval punk::mix::commandset::loadedlib { set opt_return [dict get $opts -return] set opt_highlight [dict get $opts -highlight] + #REVIEW - this doesn't result in full scans catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + if {[catch {package require natsort}]} { set has_natsort 0 } else { @@ -191,7 +193,7 @@ namespace eval punk::mix::commandset::loadedlib { } else { set has_natsort 1 } - catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + catch {package require $libname 1-0} ;#ensure pkg system has loaded/searched - using unsatisfiable version range set pkgsknown [package names] if {[set posn [lsearch $pkgsknown $libname]] >= 0} { puts stdout "Found package [lindex $pkgsknown $posn]" @@ -237,7 +239,7 @@ namespace eval punk::mix::commandset::loadedlib { set has_natsort 1 } - catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + catch {package require $library 1-0} ;#ensure pkg system has loaded/searched for everything for the path of the specified library (using unsatisfiable version range) if {[file pathtype $modulefoldername] eq "absolute"} { if {![file exists $modulefoldername]} { diff --git a/src/modules/punk/packagepreference-999999.0a1.0.tm b/src/modules/punk/packagepreference-999999.0a1.0.tm index 36656d67..a996a851 100644 --- a/src/modules/punk/packagepreference-999999.0a1.0.tm +++ b/src/modules/punk/packagepreference-999999.0a1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::packagepreference 0 999999.0a1.0] #[copyright "2024"] #[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] -#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] +#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] #[require punk::packagepreference] #[keywords module package] #[description] @@ -106,7 +106,7 @@ tcl::namespace::eval punk::packagepreference { #*** !doctools #[subsection {Namespace punk::packagepreference}] - #[para] Core API functions for punk::packagepreference + #[para] Core API functions for punk::packagepreference #[list_begin definitions] lappend PUNKARGS [list { @@ -132,7 +132,7 @@ tcl::namespace::eval punk::packagepreference { proc install {} { #*** !doctools #[call [fun install]] - #[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules + #[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules #[para](todo - check info loaded and restrict to existing version as determined from dll/so?) #[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase. #[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names" @@ -155,7 +155,7 @@ tcl::namespace::eval punk::packagepreference { #We can't provide a modernised .tm package for an old package that is commonly used with uppercase letters, in both the old form and lowercased form from a single .tm file. #It could be done by providing a redirecting .tm in a separate module path, or by providing a packageIndex.tcl to redirect it but both these solutions are error prone from a sysops perspective. set stackrecord [commandstack::rename_command -renamer punk::packagepreference package {args} { - #::package override installed by punk::packagepreference::install + #::package override installed by punk::packagepreference::install #return to previous 'package' implementation with: punk::packagepreference::uninstall #uglier but faster than tcl::prefix::match in this instance @@ -176,7 +176,7 @@ tcl::namespace::eval punk::packagepreference { set pkg [lindex $args 1] set vwant [lrange $args 2 end] ;#rare - but version can be a list of options if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { - #only one version - and it has a dash + #only one version - and it has a dash lassign [split [lindex $vwant 0] -] a b if {$a eq $b} { #string compare version nums (can contain dots and a|b) @@ -185,7 +185,7 @@ tcl::namespace::eval punk::packagepreference { } } if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} { - #although we could shortcircuit using vsatisfies to return the ver + #although we could shortcircuit using vsatisfies to return the ver #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. #e.g a package require logger further down the commandstack return [$COMMANDSTACKNEXT {*}$args] @@ -196,13 +196,13 @@ tcl::namespace::eval punk::packagepreference { set available_versions [$COMMANDSTACKNEXT_ORIGINAL versions $pkg] if {[llength $available_versions] > 1} { # --------------------------------------------------------------- - #An attempt to detect dll/so loaded and try to load same version + #An attempt to detect dll/so loaded and try to load same version #dll/so files are often named with version numbers that don't contain dots or a version number at all - #e.g sqlite3400.dll Thread288.dll + #e.g sqlite3400.dll Thread288.dll set pkgloadedinfo [lsearch -nocase -inline -index 1 [info loaded] $pkg] if {[llength $pkgloadedinfo]} { - puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available" + puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available" lassign $pkgloadedinfo path name set lcpath [string tolower $path] #first attempt to find a match for our loaded sharedlib path in a *simple* package ifneeded statement. @@ -219,7 +219,7 @@ tcl::namespace::eval punk::packagepreference { if {[dict exists $lcpath_to_version $lcpath]} { set lversion [dict get $lcpath_to_version $lcpath] - } else { + } else { #fallback to a best effort guess based on the path set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $path $pkg] } @@ -271,13 +271,13 @@ tcl::namespace::eval punk::packagepreference { #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[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" + # return "ok" #} @@ -296,14 +296,14 @@ tcl::namespace::eval punk::packagepreference::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::packagepreference::lib}] - #[para] Secondary functions that are part of the API + #[para] Secondary functions that are part of the API #[list_begin definitions] #proc utility1 {p1 args} { # #*** !doctools # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 + # #[para]Description of utility1 + # return 1 #} @@ -321,7 +321,7 @@ tcl::namespace::eval punk::packagepreference::lib { tcl::namespace::eval punk::packagepreference::system { #*** !doctools #[subsection {Namespace punk::packagepreference::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API variable PUNKARGS lappend PUNKARGS [list { @@ -330,8 +330,8 @@ tcl::namespace::eval punk::packagepreference::system { "Assistance function to determine pkg version from the information obtained from [info loaded]. This is used to try to avoid loading a different version of a binary package in another thread/interp when the package isn't - present in the interp, but [info loaded] indicates the binary is already loaded. - The more general/robust way to avoid this is to ensure ::auto_path and + present in the interp, but [info loaded] indicates the binary is already loaded. + The more general/robust way to avoid this is to ensure ::auto_path and tcl::tm::list are the same in each interp/thread. This call should only be used as a fallback in case a binary package has a more @@ -348,8 +348,8 @@ tcl::namespace::eval punk::packagepreference::system { The filename itself is first checked for a version number - but the number is ignored if it doesn't contain any dots. (prefix is checked to match with $pkgname, with a possible additional prefix - of lib or tcl) - Often (even usually) the parent or grandparent folder will be named as + of lib or tcl) + Often (even usually) the parent or grandparent folder will be named as per the package name with a proper version. If so we can return it, otherwise return empty string. The parent/grandparent matching will be done by looking for a case @@ -395,7 +395,7 @@ tcl::namespace::eval punk::packagepreference::system { } } #review - sometimes path and lib are named only for major.minor but package provides major.minor.subversion - #using returned val to attempt to package require -exact major.minor will fail to load major.minor.subversion + #using returned val to attempt to package require -exact major.minor will fail to load major.minor.subversion return "" } @@ -407,11 +407,11 @@ namespace eval ::punk::args::register { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { variable pkg punk::packagepreference variable version - set version 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/path-999999.0a1.0.tm b/src/modules/punk/path-999999.0a1.0.tm index 9c269ea0..0d99a20e 100644 --- a/src/modules/punk/path-999999.0a1.0.tm +++ b/src/modules/punk/path-999999.0a1.0.tm @@ -703,6 +703,11 @@ namespace eval punk::path { set opt_dir [dict get $opts -directory] } + #comment out to compare timings with treefilenames_zipfs + if {[string match //zipfs:/* $opt_dir]} { + return [treefilenames_zipfs {*}$args] + } + set skip 0 foreach anti $opt_antiglob_paths { if {[globmatchpath $anti $opt_dir]} { @@ -762,6 +767,138 @@ namespace eval punk::path { } return $files } + proc treefilenames_zipfs {args} { + #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW + # is sort order the same? + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + lassign [dict values $argd] leaders opts values received + set tailglobs [dict get $values tailglobs] + # -- --- --- --- --- --- --- + set opt_antiglob_paths [dict get $opts -antiglob_paths] + set opt_antiglob_files [dict get $opts -antiglob_files] + set CALLDEPTH [dict get $opts -call-depth-internal] + # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- + + set files [list] + if {$CALLDEPTH == 0} { + #set opts [dict merge $opts [list -directory $opt_dir]] + if {![dict exists $received -directory]} { + set opt_dir [pwd] + } else { + set opt_dir [dict get $opts -directory] + } + if {![file isdirectory $opt_dir]} { + return [list] + } + } else { + #assume/require to exist in any recursive call + set opt_dir [dict get $opts -directory] + } + if {![string match [zipfs root]* $opt_dir]} { + error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" + } + set dir [string trimright $opt_dir "/"] ;#e.g normalize //zipfs:/x/ to //zipfs:/x + set dirlen [string length $dir] + + set skip 0 + foreach anti $opt_antiglob_paths { + if {[globmatchpath $anti $dir]} { + set skip 1 + break + } + } + if {$skip} { + return [list] + } + set subpaths [zipfs list $dir/*] + set dirlist [list] + set skipdirs [list] + set filelist [list] + #process in the order they came - sorting large list more expensive?? review + foreach sub $subpaths { + set tail [string range $sub $dirlen+1 end] ;#dirlen is without trailing slash + set tailparts [file split $tail] + set accum "" + set skipdir 0 + foreach tp [lrange $tailparts 0 end-1] { + append accum "/$tp" + set superpath "${dir}${accum}" + if {$superpath in $skipdirs} { + #subpart already in skipdirs + set skipdir 1 + break + } + if {$superpath ni $dirlist} { + set skip2 0 + foreach anti $opt_antiglob_paths { + if {[globmatchpath $anti $superpath]} { + set skip2 1 + lappend skipdirs $superpath + break + } + } + if {!$skip2} { + lappend dirlist $superpath + } else { + set skipdir 1 + break + } + } + } + if {!$skipdir} { + #process final part of path + append accum "/[lindex $tailparts end]" + set finalpart "${dir}${accum}" + if {$finalpart ni $dirlist} { + if {[file type $finalpart] eq "file"} { + set ftail [lindex $tailparts end] + set match 0 + if {"*" ni $tailglobs} { + foreach tg $tailglobs { + if {[string match $tg $ftail]} { + set match 1 + break + } + } + } else { + set match 1 + } + if {$match} { + if {[llength $opt_antiglob_files]} { + set skipfile 0 + foreach anti $opt_antiglob_files { + if {[string match $anti $ftail]} { + set skipfile 1; break + } + } + if {!$skipfile} { + lappend filelist $finalpart + } + } else { + lappend filelist $finalpart + } + } + } else { + if {$finalpart ni $dirlist} { + set skip2 0 + foreach anti $opt_antiglob_paths { + if {[globmatchpath $anti $finalpart]} { + set skip2 1 + lappend skipdirs $finalpart + break + } + } + if {!$skip2} { + lappend dirlist $finalpart + } + } + } + } + } + } + return $filelist + } #maint warning - also in punkcheck proc relative {reference location} { diff --git a/src/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm index 2842c627..69e5dcc8 100644 --- a/src/modules/punk/repl-999999.0a1.0.tm +++ b/src/modules/punk/repl-999999.0a1.0.tm @@ -20,7 +20,18 @@ 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} + } + } +} @@ -2707,6 +2718,18 @@ 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} + } + } + } package require punk::packagepreference punk::packagepreference::install @@ -3090,7 +3113,7 @@ namespace eval repl { set nsquals [namespace qualifiers $pkg] if {$nsquals ne ""} { if {![dict exists $ns_scanned $nsquals]} { - catch {package require ${nsquals}::flubber_nonexistant} ;#force scan + catch {package require $pkg 1-0} ;#force scan with nonsatisfiable version dict set ns_scanned $nsquals 1 } } @@ -3341,6 +3364,20 @@ 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} + } + } + } + # -- --- #review #we have to blow some time on a rescan to provide more deterministic ordering (match behaviour of initial thread regarding pkg precedence) @@ -3348,12 +3385,16 @@ namespace eval repl { ##catch {package require flobrudder-nonexistant} # -- --- + set tsstart [clock millis] if {[catch { package require vfs package require vfs::zip } errM]} { - puts stderr "repl code interp can't load vfs,vfs::zip" + puts stderr "repl code interp FAILED to load vfs,vfs::zip lag:[expr {[clock millis] - $tsstart}]" + } else { + puts stderr "repl code interp loaded vfs,vfs::zip lag:[expr {[clock millis] - $tsstart}]" } + puts stderr "package unknown: [package unknown]" #puts stderr ----- #puts stderr [join $::auto_path \n] diff --git a/src/project_layouts/custom/_project/punk.basic/src/make.tcl b/src/project_layouts/custom/_project/punk.basic/src/make.tcl index 775335c3..9809dc62 100644 --- a/src/project_layouts/custom/_project/punk.basic/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.basic/src/make.tcl @@ -2254,11 +2254,11 @@ proc merge_over {sourcedir targetdir {depth 0}} { set name [dict get $linkinfo name] ;#name the linked file will become set aliased_file_or_dir [file join [file dirname $file_or_dir] $name] set relpath [fileutil::stripPath $sourcedir $aliased_file_or_dir] - set target [file join $targetdir $relpath] + set target [file join $targetdir $relpath] if {[file type $actualsource] eq "file"} { - #fauxlink linktarget (source data) is a file + #fauxlink linktarget (source data) is a file puts -nonewline stdout "\x1b\[32m\x1b\[m" - #puts "file copy -force $actualsource $target" + puts "file copy -force $actualsource $target" file copy -force $actualsource $target } else { #fauxlink linktarget (source data) is a folder @@ -2409,7 +2409,7 @@ foreach vfstail $vfs_tails { #e.g ../vfs/punk87.vfs {cksum xxxx cksum_all_opts {-cksum_content 1 ... -cksum_algorithm sha1}} dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/$vfstail] } - $vfs_event targetset_cksumcache_set $path_cksum_cache ;#cached cksum entries for .vfs folder + $vfs_event targetset_cksumcache_set $path_cksum_cache ;#cached cksum entries for .vfs folder $vfs_event targetset_addsource $sourcefolder/vfs/_config ;#some files linked via fauxlink - need to detect change $vfs_event targetset_addsource $sourcefolder/vfs/_vfscommon.vfs $vfs_event targetset_addsource $sourcefolder/vfs/$vfstail diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index fcbf6ada..f671311f 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -3398,6 +3398,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu -fullcodemerge -type boolean -default 0 -help\ "experimental" -overridecodes -type list -default {} + -rawoverrides -type ansi -default "" @values -min 1 -max 1 text -type string -help\ "String to wrap with ANSI (SGR)" @@ -3418,6 +3419,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rawresets "" set fullmerge 0 set overrides "" + set rawoverrides "" } else { set argd [punk::args::parse $args withid ::punk::ansi::ansiwrap] lassign [dict values $argd] leaders opts values received solos @@ -3428,6 +3430,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rawresets [dict get $opts -rawresets] set fullmerge [dict get $opts -fullcodemerge] set overrides [punk::ansi::ta::get_codes_single [a+ {*}[dict get $opts -overridecodes]]] + set rawoverrides [punk::ansi::ta::get_codes_single [dict get $opts -rawoverrides]] } #note that the result of any sgr_merge or sgr_merge_singles is not necessarily a single Ansi escape sequence. @@ -3450,6 +3453,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set R [punk::ansi::codetype::sgr_merge_singles [list $R {*}$rawresetcodes]] } } + if {$rawoverrides ne ""} { + set rawoverridecodes [punk::ansi::ta::get_codes_single $rawoverrides] + set overrides [list {*}$overrides {*}$rawoverridecodes] + } set codestack [list] if {[punk::ansi::ta::detect $text]} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm index f2f85349..e278d99f 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm @@ -372,8 +372,10 @@ tcl::namespace::eval punk::config { set config_home [dict get $configdata startup xdg_config_home] if {![file exists $config_home]} { - puts stderr "punk::config::init creating punk shell config dir: [dir]" - puts stderr "(todo)" + puts stderr "punk::config::init creating punk shell config dir: $config_home" + if {[catch {file mkdir $config_home} errM]} { + puts stderr "punk::config::init failed to create dir at $config_home\n$errM" + } } set configset [dict get $configdata defaults configset] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm index b964d228..5e12b9a2 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -50,7 +50,9 @@ namespace eval punk::mix::commandset::loadedlib { set opt_return [dict get $opts -return] set opt_highlight [dict get $opts -highlight] + #REVIEW - this doesn't result in full scans catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + if {[catch {package require natsort}]} { set has_natsort 0 } else { @@ -191,7 +193,7 @@ namespace eval punk::mix::commandset::loadedlib { } else { set has_natsort 1 } - catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + catch {package require $libname 1-0} ;#ensure pkg system has loaded/searched - using unsatisfiable version range set pkgsknown [package names] if {[set posn [lsearch $pkgsknown $libname]] >= 0} { puts stdout "Found package [lindex $pkgsknown $posn]" @@ -237,7 +239,7 @@ namespace eval punk::mix::commandset::loadedlib { set has_natsort 1 } - catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + catch {package require $library 1-0} ;#ensure pkg system has loaded/searched for everything for the path of the specified library (using unsatisfiable version range) if {[file pathtype $modulefoldername] eq "absolute"} { if {![file exists $modulefoldername]} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm index 254c90bf..d823a923 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::packagepreference 0 0.1.0] #[copyright "2024"] #[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] -#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] +#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] #[require punk::packagepreference] #[keywords module package] #[description] @@ -106,7 +106,7 @@ tcl::namespace::eval punk::packagepreference { #*** !doctools #[subsection {Namespace punk::packagepreference}] - #[para] Core API functions for punk::packagepreference + #[para] Core API functions for punk::packagepreference #[list_begin definitions] lappend PUNKARGS [list { @@ -132,7 +132,7 @@ tcl::namespace::eval punk::packagepreference { proc install {} { #*** !doctools #[call [fun install]] - #[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules + #[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules #[para](todo - check info loaded and restrict to existing version as determined from dll/so?) #[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase. #[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names" @@ -155,7 +155,7 @@ tcl::namespace::eval punk::packagepreference { #We can't provide a modernised .tm package for an old package that is commonly used with uppercase letters, in both the old form and lowercased form from a single .tm file. #It could be done by providing a redirecting .tm in a separate module path, or by providing a packageIndex.tcl to redirect it but both these solutions are error prone from a sysops perspective. set stackrecord [commandstack::rename_command -renamer punk::packagepreference package {args} { - #::package override installed by punk::packagepreference::install + #::package override installed by punk::packagepreference::install #return to previous 'package' implementation with: punk::packagepreference::uninstall #uglier but faster than tcl::prefix::match in this instance @@ -176,7 +176,7 @@ tcl::namespace::eval punk::packagepreference { set pkg [lindex $args 1] set vwant [lrange $args 2 end] ;#rare - but version can be a list of options if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { - #only one version - and it has a dash + #only one version - and it has a dash lassign [split [lindex $vwant 0] -] a b if {$a eq $b} { #string compare version nums (can contain dots and a|b) @@ -185,7 +185,7 @@ tcl::namespace::eval punk::packagepreference { } } if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} { - #although we could shortcircuit using vsatisfies to return the ver + #although we could shortcircuit using vsatisfies to return the ver #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. #e.g a package require logger further down the commandstack return [$COMMANDSTACKNEXT {*}$args] @@ -196,13 +196,13 @@ tcl::namespace::eval punk::packagepreference { set available_versions [$COMMANDSTACKNEXT_ORIGINAL versions $pkg] if {[llength $available_versions] > 1} { # --------------------------------------------------------------- - #An attempt to detect dll/so loaded and try to load same version + #An attempt to detect dll/so loaded and try to load same version #dll/so files are often named with version numbers that don't contain dots or a version number at all - #e.g sqlite3400.dll Thread288.dll + #e.g sqlite3400.dll Thread288.dll set pkgloadedinfo [lsearch -nocase -inline -index 1 [info loaded] $pkg] if {[llength $pkgloadedinfo]} { - puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available" + puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available" lassign $pkgloadedinfo path name set lcpath [string tolower $path] #first attempt to find a match for our loaded sharedlib path in a *simple* package ifneeded statement. @@ -219,7 +219,7 @@ tcl::namespace::eval punk::packagepreference { if {[dict exists $lcpath_to_version $lcpath]} { set lversion [dict get $lcpath_to_version $lcpath] - } else { + } else { #fallback to a best effort guess based on the path set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $path $pkg] } @@ -271,13 +271,13 @@ tcl::namespace::eval punk::packagepreference { #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[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" + # return "ok" #} @@ -296,14 +296,14 @@ tcl::namespace::eval punk::packagepreference::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::packagepreference::lib}] - #[para] Secondary functions that are part of the API + #[para] Secondary functions that are part of the API #[list_begin definitions] #proc utility1 {p1 args} { # #*** !doctools # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 + # #[para]Description of utility1 + # return 1 #} @@ -321,7 +321,7 @@ tcl::namespace::eval punk::packagepreference::lib { tcl::namespace::eval punk::packagepreference::system { #*** !doctools #[subsection {Namespace punk::packagepreference::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API variable PUNKARGS lappend PUNKARGS [list { @@ -330,8 +330,8 @@ tcl::namespace::eval punk::packagepreference::system { "Assistance function to determine pkg version from the information obtained from [info loaded]. This is used to try to avoid loading a different version of a binary package in another thread/interp when the package isn't - present in the interp, but [info loaded] indicates the binary is already loaded. - The more general/robust way to avoid this is to ensure ::auto_path and + present in the interp, but [info loaded] indicates the binary is already loaded. + The more general/robust way to avoid this is to ensure ::auto_path and tcl::tm::list are the same in each interp/thread. This call should only be used as a fallback in case a binary package has a more @@ -348,8 +348,8 @@ tcl::namespace::eval punk::packagepreference::system { The filename itself is first checked for a version number - but the number is ignored if it doesn't contain any dots. (prefix is checked to match with $pkgname, with a possible additional prefix - of lib or tcl) - Often (even usually) the parent or grandparent folder will be named as + of lib or tcl) + Often (even usually) the parent or grandparent folder will be named as per the package name with a proper version. If so we can return it, otherwise return empty string. The parent/grandparent matching will be done by looking for a case @@ -395,7 +395,7 @@ tcl::namespace::eval punk::packagepreference::system { } } #review - sometimes path and lib are named only for major.minor but package provides major.minor.subversion - #using returned val to attempt to package require -exact major.minor will fail to load major.minor.subversion + #using returned val to attempt to package require -exact major.minor will fail to load major.minor.subversion return "" } @@ -407,11 +407,11 @@ namespace eval ::punk::args::register { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { variable pkg punk::packagepreference variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm index 1ddd56b7..ff48fcb0 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm @@ -703,6 +703,11 @@ namespace eval punk::path { set opt_dir [dict get $opts -directory] } + #comment out to compare timings with treefilenames_zipfs + if {[string match //zipfs:/* $opt_dir]} { + return [treefilenames_zipfs {*}$args] + } + set skip 0 foreach anti $opt_antiglob_paths { if {[globmatchpath $anti $opt_dir]} { @@ -762,6 +767,138 @@ namespace eval punk::path { } return $files } + proc treefilenames_zipfs {args} { + #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW + # is sort order the same? + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + lassign [dict values $argd] leaders opts values received + set tailglobs [dict get $values tailglobs] + # -- --- --- --- --- --- --- + set opt_antiglob_paths [dict get $opts -antiglob_paths] + set opt_antiglob_files [dict get $opts -antiglob_files] + set CALLDEPTH [dict get $opts -call-depth-internal] + # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- + + set files [list] + if {$CALLDEPTH == 0} { + #set opts [dict merge $opts [list -directory $opt_dir]] + if {![dict exists $received -directory]} { + set opt_dir [pwd] + } else { + set opt_dir [dict get $opts -directory] + } + if {![file isdirectory $opt_dir]} { + return [list] + } + } else { + #assume/require to exist in any recursive call + set opt_dir [dict get $opts -directory] + } + if {![string match [zipfs root]* $opt_dir]} { + error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" + } + set dir [string trimright $opt_dir "/"] ;#e.g normalize //zipfs:/x/ to //zipfs:/x + set dirlen [string length $dir] + + set skip 0 + foreach anti $opt_antiglob_paths { + if {[globmatchpath $anti $dir]} { + set skip 1 + break + } + } + if {$skip} { + return [list] + } + set subpaths [zipfs list $dir/*] + set dirlist [list] + set skipdirs [list] + set filelist [list] + #process in the order they came - sorting large list more expensive?? review + foreach sub $subpaths { + set tail [string range $sub $dirlen+1 end] ;#dirlen is without trailing slash + set tailparts [file split $tail] + set accum "" + set skipdir 0 + foreach tp [lrange $tailparts 0 end-1] { + append accum "/$tp" + set superpath "${dir}${accum}" + if {$superpath in $skipdirs} { + #subpart already in skipdirs + set skipdir 1 + break + } + if {$superpath ni $dirlist} { + set skip2 0 + foreach anti $opt_antiglob_paths { + if {[globmatchpath $anti $superpath]} { + set skip2 1 + lappend skipdirs $superpath + break + } + } + if {!$skip2} { + lappend dirlist $superpath + } else { + set skipdir 1 + break + } + } + } + if {!$skipdir} { + #process final part of path + append accum "/[lindex $tailparts end]" + set finalpart "${dir}${accum}" + if {$finalpart ni $dirlist} { + if {[file type $finalpart] eq "file"} { + set ftail [lindex $tailparts end] + set match 0 + if {"*" ni $tailglobs} { + foreach tg $tailglobs { + if {[string match $tg $ftail]} { + set match 1 + break + } + } + } else { + set match 1 + } + if {$match} { + if {[llength $opt_antiglob_files]} { + set skipfile 0 + foreach anti $opt_antiglob_files { + if {[string match $anti $ftail]} { + set skipfile 1; break + } + } + if {!$skipfile} { + lappend filelist $finalpart + } + } else { + lappend filelist $finalpart + } + } + } else { + if {$finalpart ni $dirlist} { + set skip2 0 + foreach anti $opt_antiglob_paths { + if {[globmatchpath $anti $finalpart]} { + set skip2 1 + lappend skipdirs $finalpart + break + } + } + if {!$skip2} { + lappend dirlist $finalpart + } + } + } + } + } + } + return $filelist + } #maint warning - also in punkcheck proc relative {reference location} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl index 775335c3..9809dc62 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl @@ -2254,11 +2254,11 @@ proc merge_over {sourcedir targetdir {depth 0}} { set name [dict get $linkinfo name] ;#name the linked file will become set aliased_file_or_dir [file join [file dirname $file_or_dir] $name] set relpath [fileutil::stripPath $sourcedir $aliased_file_or_dir] - set target [file join $targetdir $relpath] + set target [file join $targetdir $relpath] if {[file type $actualsource] eq "file"} { - #fauxlink linktarget (source data) is a file + #fauxlink linktarget (source data) is a file puts -nonewline stdout "\x1b\[32m\x1b\[m" - #puts "file copy -force $actualsource $target" + puts "file copy -force $actualsource $target" file copy -force $actualsource $target } else { #fauxlink linktarget (source data) is a folder @@ -2409,7 +2409,7 @@ foreach vfstail $vfs_tails { #e.g ../vfs/punk87.vfs {cksum xxxx cksum_all_opts {-cksum_content 1 ... -cksum_algorithm sha1}} dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/$vfstail] } - $vfs_event targetset_cksumcache_set $path_cksum_cache ;#cached cksum entries for .vfs folder + $vfs_event targetset_cksumcache_set $path_cksum_cache ;#cached cksum entries for .vfs folder $vfs_event targetset_addsource $sourcefolder/vfs/_config ;#some files linked via fauxlink - need to detect change $vfs_event targetset_addsource $sourcefolder/vfs/_vfscommon.vfs $vfs_event targetset_addsource $sourcefolder/vfs/$vfstail diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index fcbf6ada..f671311f 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -3398,6 +3398,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu -fullcodemerge -type boolean -default 0 -help\ "experimental" -overridecodes -type list -default {} + -rawoverrides -type ansi -default "" @values -min 1 -max 1 text -type string -help\ "String to wrap with ANSI (SGR)" @@ -3418,6 +3419,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rawresets "" set fullmerge 0 set overrides "" + set rawoverrides "" } else { set argd [punk::args::parse $args withid ::punk::ansi::ansiwrap] lassign [dict values $argd] leaders opts values received solos @@ -3428,6 +3430,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rawresets [dict get $opts -rawresets] set fullmerge [dict get $opts -fullcodemerge] set overrides [punk::ansi::ta::get_codes_single [a+ {*}[dict get $opts -overridecodes]]] + set rawoverrides [punk::ansi::ta::get_codes_single [dict get $opts -rawoverrides]] } #note that the result of any sgr_merge or sgr_merge_singles is not necessarily a single Ansi escape sequence. @@ -3450,6 +3453,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set R [punk::ansi::codetype::sgr_merge_singles [list $R {*}$rawresetcodes]] } } + if {$rawoverrides ne ""} { + set rawoverridecodes [punk::ansi::ta::get_codes_single $rawoverrides] + set overrides [list {*}$overrides {*}$rawoverridecodes] + } set codestack [list] if {[punk::ansi::ta::detect $text]} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm index f2f85349..e278d99f 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm @@ -372,8 +372,10 @@ tcl::namespace::eval punk::config { set config_home [dict get $configdata startup xdg_config_home] if {![file exists $config_home]} { - puts stderr "punk::config::init creating punk shell config dir: [dir]" - puts stderr "(todo)" + puts stderr "punk::config::init creating punk shell config dir: $config_home" + if {[catch {file mkdir $config_home} errM]} { + puts stderr "punk::config::init failed to create dir at $config_home\n$errM" + } } set configset [dict get $configdata defaults configset] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm index b964d228..5e12b9a2 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -50,7 +50,9 @@ namespace eval punk::mix::commandset::loadedlib { set opt_return [dict get $opts -return] set opt_highlight [dict get $opts -highlight] + #REVIEW - this doesn't result in full scans catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + if {[catch {package require natsort}]} { set has_natsort 0 } else { @@ -191,7 +193,7 @@ namespace eval punk::mix::commandset::loadedlib { } else { set has_natsort 1 } - catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + catch {package require $libname 1-0} ;#ensure pkg system has loaded/searched - using unsatisfiable version range set pkgsknown [package names] if {[set posn [lsearch $pkgsknown $libname]] >= 0} { puts stdout "Found package [lindex $pkgsknown $posn]" @@ -237,7 +239,7 @@ namespace eval punk::mix::commandset::loadedlib { set has_natsort 1 } - catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + catch {package require $library 1-0} ;#ensure pkg system has loaded/searched for everything for the path of the specified library (using unsatisfiable version range) if {[file pathtype $modulefoldername] eq "absolute"} { if {![file exists $modulefoldername]} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm index 254c90bf..d823a923 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::packagepreference 0 0.1.0] #[copyright "2024"] #[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] -#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] +#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] #[require punk::packagepreference] #[keywords module package] #[description] @@ -106,7 +106,7 @@ tcl::namespace::eval punk::packagepreference { #*** !doctools #[subsection {Namespace punk::packagepreference}] - #[para] Core API functions for punk::packagepreference + #[para] Core API functions for punk::packagepreference #[list_begin definitions] lappend PUNKARGS [list { @@ -132,7 +132,7 @@ tcl::namespace::eval punk::packagepreference { proc install {} { #*** !doctools #[call [fun install]] - #[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules + #[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules #[para](todo - check info loaded and restrict to existing version as determined from dll/so?) #[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase. #[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names" @@ -155,7 +155,7 @@ tcl::namespace::eval punk::packagepreference { #We can't provide a modernised .tm package for an old package that is commonly used with uppercase letters, in both the old form and lowercased form from a single .tm file. #It could be done by providing a redirecting .tm in a separate module path, or by providing a packageIndex.tcl to redirect it but both these solutions are error prone from a sysops perspective. set stackrecord [commandstack::rename_command -renamer punk::packagepreference package {args} { - #::package override installed by punk::packagepreference::install + #::package override installed by punk::packagepreference::install #return to previous 'package' implementation with: punk::packagepreference::uninstall #uglier but faster than tcl::prefix::match in this instance @@ -176,7 +176,7 @@ tcl::namespace::eval punk::packagepreference { set pkg [lindex $args 1] set vwant [lrange $args 2 end] ;#rare - but version can be a list of options if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { - #only one version - and it has a dash + #only one version - and it has a dash lassign [split [lindex $vwant 0] -] a b if {$a eq $b} { #string compare version nums (can contain dots and a|b) @@ -185,7 +185,7 @@ tcl::namespace::eval punk::packagepreference { } } if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} { - #although we could shortcircuit using vsatisfies to return the ver + #although we could shortcircuit using vsatisfies to return the ver #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. #e.g a package require logger further down the commandstack return [$COMMANDSTACKNEXT {*}$args] @@ -196,13 +196,13 @@ tcl::namespace::eval punk::packagepreference { set available_versions [$COMMANDSTACKNEXT_ORIGINAL versions $pkg] if {[llength $available_versions] > 1} { # --------------------------------------------------------------- - #An attempt to detect dll/so loaded and try to load same version + #An attempt to detect dll/so loaded and try to load same version #dll/so files are often named with version numbers that don't contain dots or a version number at all - #e.g sqlite3400.dll Thread288.dll + #e.g sqlite3400.dll Thread288.dll set pkgloadedinfo [lsearch -nocase -inline -index 1 [info loaded] $pkg] if {[llength $pkgloadedinfo]} { - puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available" + puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available" lassign $pkgloadedinfo path name set lcpath [string tolower $path] #first attempt to find a match for our loaded sharedlib path in a *simple* package ifneeded statement. @@ -219,7 +219,7 @@ tcl::namespace::eval punk::packagepreference { if {[dict exists $lcpath_to_version $lcpath]} { set lversion [dict get $lcpath_to_version $lcpath] - } else { + } else { #fallback to a best effort guess based on the path set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $path $pkg] } @@ -271,13 +271,13 @@ tcl::namespace::eval punk::packagepreference { #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[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" + # return "ok" #} @@ -296,14 +296,14 @@ tcl::namespace::eval punk::packagepreference::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::packagepreference::lib}] - #[para] Secondary functions that are part of the API + #[para] Secondary functions that are part of the API #[list_begin definitions] #proc utility1 {p1 args} { # #*** !doctools # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 + # #[para]Description of utility1 + # return 1 #} @@ -321,7 +321,7 @@ tcl::namespace::eval punk::packagepreference::lib { tcl::namespace::eval punk::packagepreference::system { #*** !doctools #[subsection {Namespace punk::packagepreference::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API variable PUNKARGS lappend PUNKARGS [list { @@ -330,8 +330,8 @@ tcl::namespace::eval punk::packagepreference::system { "Assistance function to determine pkg version from the information obtained from [info loaded]. This is used to try to avoid loading a different version of a binary package in another thread/interp when the package isn't - present in the interp, but [info loaded] indicates the binary is already loaded. - The more general/robust way to avoid this is to ensure ::auto_path and + present in the interp, but [info loaded] indicates the binary is already loaded. + The more general/robust way to avoid this is to ensure ::auto_path and tcl::tm::list are the same in each interp/thread. This call should only be used as a fallback in case a binary package has a more @@ -348,8 +348,8 @@ tcl::namespace::eval punk::packagepreference::system { The filename itself is first checked for a version number - but the number is ignored if it doesn't contain any dots. (prefix is checked to match with $pkgname, with a possible additional prefix - of lib or tcl) - Often (even usually) the parent or grandparent folder will be named as + of lib or tcl) + Often (even usually) the parent or grandparent folder will be named as per the package name with a proper version. If so we can return it, otherwise return empty string. The parent/grandparent matching will be done by looking for a case @@ -395,7 +395,7 @@ tcl::namespace::eval punk::packagepreference::system { } } #review - sometimes path and lib are named only for major.minor but package provides major.minor.subversion - #using returned val to attempt to package require -exact major.minor will fail to load major.minor.subversion + #using returned val to attempt to package require -exact major.minor will fail to load major.minor.subversion return "" } @@ -407,11 +407,11 @@ namespace eval ::punk::args::register { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { variable pkg punk::packagepreference variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm index 1ddd56b7..ff48fcb0 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm @@ -703,6 +703,11 @@ namespace eval punk::path { set opt_dir [dict get $opts -directory] } + #comment out to compare timings with treefilenames_zipfs + if {[string match //zipfs:/* $opt_dir]} { + return [treefilenames_zipfs {*}$args] + } + set skip 0 foreach anti $opt_antiglob_paths { if {[globmatchpath $anti $opt_dir]} { @@ -762,6 +767,138 @@ namespace eval punk::path { } return $files } + proc treefilenames_zipfs {args} { + #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW + # is sort order the same? + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + lassign [dict values $argd] leaders opts values received + set tailglobs [dict get $values tailglobs] + # -- --- --- --- --- --- --- + set opt_antiglob_paths [dict get $opts -antiglob_paths] + set opt_antiglob_files [dict get $opts -antiglob_files] + set CALLDEPTH [dict get $opts -call-depth-internal] + # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- + + set files [list] + if {$CALLDEPTH == 0} { + #set opts [dict merge $opts [list -directory $opt_dir]] + if {![dict exists $received -directory]} { + set opt_dir [pwd] + } else { + set opt_dir [dict get $opts -directory] + } + if {![file isdirectory $opt_dir]} { + return [list] + } + } else { + #assume/require to exist in any recursive call + set opt_dir [dict get $opts -directory] + } + if {![string match [zipfs root]* $opt_dir]} { + error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" + } + set dir [string trimright $opt_dir "/"] ;#e.g normalize //zipfs:/x/ to //zipfs:/x + set dirlen [string length $dir] + + set skip 0 + foreach anti $opt_antiglob_paths { + if {[globmatchpath $anti $dir]} { + set skip 1 + break + } + } + if {$skip} { + return [list] + } + set subpaths [zipfs list $dir/*] + set dirlist [list] + set skipdirs [list] + set filelist [list] + #process in the order they came - sorting large list more expensive?? review + foreach sub $subpaths { + set tail [string range $sub $dirlen+1 end] ;#dirlen is without trailing slash + set tailparts [file split $tail] + set accum "" + set skipdir 0 + foreach tp [lrange $tailparts 0 end-1] { + append accum "/$tp" + set superpath "${dir}${accum}" + if {$superpath in $skipdirs} { + #subpart already in skipdirs + set skipdir 1 + break + } + if {$superpath ni $dirlist} { + set skip2 0 + foreach anti $opt_antiglob_paths { + if {[globmatchpath $anti $superpath]} { + set skip2 1 + lappend skipdirs $superpath + break + } + } + if {!$skip2} { + lappend dirlist $superpath + } else { + set skipdir 1 + break + } + } + } + if {!$skipdir} { + #process final part of path + append accum "/[lindex $tailparts end]" + set finalpart "${dir}${accum}" + if {$finalpart ni $dirlist} { + if {[file type $finalpart] eq "file"} { + set ftail [lindex $tailparts end] + set match 0 + if {"*" ni $tailglobs} { + foreach tg $tailglobs { + if {[string match $tg $ftail]} { + set match 1 + break + } + } + } else { + set match 1 + } + if {$match} { + if {[llength $opt_antiglob_files]} { + set skipfile 0 + foreach anti $opt_antiglob_files { + if {[string match $anti $ftail]} { + set skipfile 1; break + } + } + if {!$skipfile} { + lappend filelist $finalpart + } + } else { + lappend filelist $finalpart + } + } + } else { + if {$finalpart ni $dirlist} { + set skip2 0 + foreach anti $opt_antiglob_paths { + if {[globmatchpath $anti $finalpart]} { + set skip2 1 + lappend skipdirs $finalpart + break + } + } + if {!$skip2} { + lappend dirlist $finalpart + } + } + } + } + } + } + return $filelist + } #maint warning - also in punkcheck proc relative {reference location} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl index 775335c3..9809dc62 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl @@ -2254,11 +2254,11 @@ proc merge_over {sourcedir targetdir {depth 0}} { set name [dict get $linkinfo name] ;#name the linked file will become set aliased_file_or_dir [file join [file dirname $file_or_dir] $name] set relpath [fileutil::stripPath $sourcedir $aliased_file_or_dir] - set target [file join $targetdir $relpath] + set target [file join $targetdir $relpath] if {[file type $actualsource] eq "file"} { - #fauxlink linktarget (source data) is a file + #fauxlink linktarget (source data) is a file puts -nonewline stdout "\x1b\[32m\x1b\[m" - #puts "file copy -force $actualsource $target" + puts "file copy -force $actualsource $target" file copy -force $actualsource $target } else { #fauxlink linktarget (source data) is a folder @@ -2409,7 +2409,7 @@ foreach vfstail $vfs_tails { #e.g ../vfs/punk87.vfs {cksum xxxx cksum_all_opts {-cksum_content 1 ... -cksum_algorithm sha1}} dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/$vfstail] } - $vfs_event targetset_cksumcache_set $path_cksum_cache ;#cached cksum entries for .vfs folder + $vfs_event targetset_cksumcache_set $path_cksum_cache ;#cached cksum entries for .vfs folder $vfs_event targetset_addsource $sourcefolder/vfs/_config ;#some files linked via fauxlink - need to detect change $vfs_event targetset_addsource $sourcefolder/vfs/_vfscommon.vfs $vfs_event targetset_addsource $sourcefolder/vfs/$vfstail diff --git a/src/vfs/_config/modules/punk/libunknown.tm b/src/vfs/_config/modules/punk/libunknown.tm new file mode 100644 index 00000000..58173834 --- /dev/null +++ b/src/vfs/_config/modules/punk/libunknown.tm @@ -0,0 +1,673 @@ +# -*- 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 4aba3e6d..52530a5b 100644 --- a/src/vfs/_config/punk_main.tcl +++ b/src/vfs/_config/punk_main.tcl @@ -104,7 +104,7 @@ apply { args { #on windows make the .exe point there too set ::auto_execs($thisexe) [info nameofexecutable] } - # -- --- --- + # -- --- --- if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} { set kp $::tcl::kitpath @@ -123,12 +123,12 @@ apply { args { if {$has_zipfs_attached} { #review build option may be different - tclZipFs.c ZIPFS_APP_MOUNT defaults to ZIPFS_VOLUME/app - but it could be something else. (why?) #default 'zipfs root' has trailing slash (//zipfs:/) - but file join does the right thing - set zipbase [file join [tcl::zipfs::root] app] + set zipbase [file join [tcl::zipfs::root] app] if {"$zipbase" in [tcl::zipfs::mount]} { set existing_module_paths [string tolower [tcl::tm::list]] foreach p [list modules modules_tcl$tclmajorv] { if {[string tolower [file join $zipbase $p]] ni $existing_module_paths} { - tcl::tm::add [file join $zipbase $p] + tcl::tm::add [file join $zipbase $p] } } foreach l [list lib lib_tcl$tclmajorv] { @@ -142,7 +142,7 @@ apply { args { set existing_module_paths [string tolower [tcl::tm::list]] foreach p [list modules modules_tcl$tclmajorv] { if {[string tolower [file join $cookbase $p]] ni $existing_module_paths} { - tcl::tm::add [file join $cookbase $p] + tcl::tm::add [file join $cookbase $p] } } foreach l [list lib lib_tcl$tclmajorv] { @@ -373,14 +373,14 @@ apply { args { if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} { #prepend set external_tm_dirs [linsert $external_tm_dirs 0 $cwd_modules_folder] - } + } } set cwd_modules_folder [file normalize [file join [pwd] modules_tcl$tclmajorv]] if {[file isdirectory $cwd_modules_folder]} { if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} { #prepend set external_tm_dirs [linsert $external_tm_dirs 0 $cwd_modules_folder] - } + } } } @@ -415,7 +415,7 @@ apply { args { } else { - #not dev/devquiet + #not dev/devquiet #Tcl_Init will most likely have set up some external paths #As our app has been started without the 'dev' first arg - we will prune paths that are not zipfs or tclkit #(or set via punkboot::internal_paths) @@ -498,6 +498,19 @@ apply { args { set arglist $args } + if {$has_zipfs_attached} { + 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} + } + } + } + #assert arglist has had 'dev' first arg removed if it was present. if {[llength $arglist] == 1 && [lindex $arglist 0] eq "tclsh"} { #called as dev tclsh or tclsh @@ -534,8 +547,9 @@ apply { args { #punk shell #todo logger ? #puts stdout "main.tcl launching app-punk. pkg names count:[llength [package names]]" - #puts ">> $::auto_path" - #puts ">>> [tcl::tm::list]" + #puts ">> $::auto_path" + #puts ">>> [tcl::tm::list]" + #puts ">>>> [package unknown]" package require app-punk #app-punk starts repl #repl::start stdin -title "main.tcl" diff --git a/src/vfs/_vfscommon.vfs/lib/zint-2.13.0/licence.txt b/src/vfs/_vfscommon.vfs/lib/zint-2.13.0/licence.txt deleted file mode 100644 index 795e883e..00000000 --- a/src/vfs/_vfscommon.vfs/lib/zint-2.13.0/licence.txt +++ /dev/null @@ -1,14 +0,0 @@ -Copyright (c) 2023 Robin Stuart -All rights reserved. - -Redistribution and use in source and binary forms are permitted -provided that the above copyright notice and this paragraph are -duplicated in all such forms and that any documentation, -advertising materials, and other materials related to such -distribution and use acknowledge that the software was developed -by the . The name of the - may not be used to endorse or promote products derived -from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. diff --git a/src/vfs/_vfscommon.vfs/lib/zint-2.13.0/pkgIndex.tcl b/src/vfs/_vfscommon.vfs/lib/zint-2.13.0/pkgIndex.tcl deleted file mode 100644 index e4c9a073..00000000 --- a/src/vfs/_vfscommon.vfs/lib/zint-2.13.0/pkgIndex.tcl +++ /dev/null @@ -1,2 +0,0 @@ -package ifneeded zint 2.13.0\ - [list load [file join $dir zint[info sharedlibextension]]] diff --git a/src/vfs/_vfscommon.vfs/lib/zint-2.13.0/readme.txt b/src/vfs/_vfscommon.vfs/lib/zint-2.13.0/readme.txt deleted file mode 100644 index 50ede106..00000000 --- a/src/vfs/_vfscommon.vfs/lib/zint-2.13.0/readme.txt +++ /dev/null @@ -1,27 +0,0 @@ - zint tcl binding readme - ----------------------- - 2014-06-30 - (C) Harald Oehlmann - harald.oehlmann@users.sourceforge.net - -What: tcl binding for zint bar code generator library - -Build: -The header files of a TCL and Tk build are required for the build. - -- MS-VC6 project file "zint_tcl.dsp" may be opened by the GUI. - (will need to add your version of tcl/tk libs to LINK32, e.g. - "tcl85.lib" and "tk85.lib") -- Linux/Unix build is provided by the configure script. - Thanks to Christian Werner for that. - -Usage: - -load zint.dll -zint help - -Most options are identical to the command line tool. -Details may be found in the zint manual. - -Demo: -The demo folder contains a visual demo program. diff --git a/src/vfs/_vfscommon.vfs/lib/zint-2.13.0/zint.dll b/src/vfs/_vfscommon.vfs/lib/zint-2.13.0/zint.dll deleted file mode 100644 index fe3578af..00000000 Binary files a/src/vfs/_vfscommon.vfs/lib/zint-2.13.0/zint.dll and /dev/null differ diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm index fcbf6ada..f671311f 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm @@ -3398,6 +3398,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu -fullcodemerge -type boolean -default 0 -help\ "experimental" -overridecodes -type list -default {} + -rawoverrides -type ansi -default "" @values -min 1 -max 1 text -type string -help\ "String to wrap with ANSI (SGR)" @@ -3418,6 +3419,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rawresets "" set fullmerge 0 set overrides "" + set rawoverrides "" } else { set argd [punk::args::parse $args withid ::punk::ansi::ansiwrap] lassign [dict values $argd] leaders opts values received solos @@ -3428,6 +3430,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rawresets [dict get $opts -rawresets] set fullmerge [dict get $opts -fullcodemerge] set overrides [punk::ansi::ta::get_codes_single [a+ {*}[dict get $opts -overridecodes]]] + set rawoverrides [punk::ansi::ta::get_codes_single [dict get $opts -rawoverrides]] } #note that the result of any sgr_merge or sgr_merge_singles is not necessarily a single Ansi escape sequence. @@ -3450,6 +3453,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set R [punk::ansi::codetype::sgr_merge_singles [list $R {*}$rawresetcodes]] } } + if {$rawoverrides ne ""} { + set rawoverridecodes [punk::ansi::ta::get_codes_single $rawoverrides] + set overrides [list {*}$overrides {*}$rawoverridecodes] + } set codestack [list] if {[punk::ansi::ta::detect $text]} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/loadedlib-0.1.0.tm index b964d228..5e12b9a2 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -50,7 +50,9 @@ namespace eval punk::mix::commandset::loadedlib { set opt_return [dict get $opts -return] set opt_highlight [dict get $opts -highlight] + #REVIEW - this doesn't result in full scans catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + if {[catch {package require natsort}]} { set has_natsort 0 } else { @@ -191,7 +193,7 @@ namespace eval punk::mix::commandset::loadedlib { } else { set has_natsort 1 } - catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + catch {package require $libname 1-0} ;#ensure pkg system has loaded/searched - using unsatisfiable version range set pkgsknown [package names] if {[set posn [lsearch $pkgsknown $libname]] >= 0} { puts stdout "Found package [lindex $pkgsknown $posn]" @@ -237,7 +239,7 @@ namespace eval punk::mix::commandset::loadedlib { set has_natsort 1 } - catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + catch {package require $library 1-0} ;#ensure pkg system has loaded/searched for everything for the path of the specified library (using unsatisfiable version range) if {[file pathtype $modulefoldername] eq "absolute"} { if {![file exists $modulefoldername]} { 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 254c90bf..d823a923 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 @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::packagepreference 0 0.1.0] #[copyright "2024"] #[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] -#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] +#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] #[require punk::packagepreference] #[keywords module package] #[description] @@ -106,7 +106,7 @@ tcl::namespace::eval punk::packagepreference { #*** !doctools #[subsection {Namespace punk::packagepreference}] - #[para] Core API functions for punk::packagepreference + #[para] Core API functions for punk::packagepreference #[list_begin definitions] lappend PUNKARGS [list { @@ -132,7 +132,7 @@ tcl::namespace::eval punk::packagepreference { proc install {} { #*** !doctools #[call [fun install]] - #[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules + #[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules #[para](todo - check info loaded and restrict to existing version as determined from dll/so?) #[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase. #[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names" @@ -155,7 +155,7 @@ tcl::namespace::eval punk::packagepreference { #We can't provide a modernised .tm package for an old package that is commonly used with uppercase letters, in both the old form and lowercased form from a single .tm file. #It could be done by providing a redirecting .tm in a separate module path, or by providing a packageIndex.tcl to redirect it but both these solutions are error prone from a sysops perspective. set stackrecord [commandstack::rename_command -renamer punk::packagepreference package {args} { - #::package override installed by punk::packagepreference::install + #::package override installed by punk::packagepreference::install #return to previous 'package' implementation with: punk::packagepreference::uninstall #uglier but faster than tcl::prefix::match in this instance @@ -176,7 +176,7 @@ tcl::namespace::eval punk::packagepreference { set pkg [lindex $args 1] set vwant [lrange $args 2 end] ;#rare - but version can be a list of options if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { - #only one version - and it has a dash + #only one version - and it has a dash lassign [split [lindex $vwant 0] -] a b if {$a eq $b} { #string compare version nums (can contain dots and a|b) @@ -185,7 +185,7 @@ tcl::namespace::eval punk::packagepreference { } } if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} { - #although we could shortcircuit using vsatisfies to return the ver + #although we could shortcircuit using vsatisfies to return the ver #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. #e.g a package require logger further down the commandstack return [$COMMANDSTACKNEXT {*}$args] @@ -196,13 +196,13 @@ tcl::namespace::eval punk::packagepreference { set available_versions [$COMMANDSTACKNEXT_ORIGINAL versions $pkg] if {[llength $available_versions] > 1} { # --------------------------------------------------------------- - #An attempt to detect dll/so loaded and try to load same version + #An attempt to detect dll/so loaded and try to load same version #dll/so files are often named with version numbers that don't contain dots or a version number at all - #e.g sqlite3400.dll Thread288.dll + #e.g sqlite3400.dll Thread288.dll set pkgloadedinfo [lsearch -nocase -inline -index 1 [info loaded] $pkg] if {[llength $pkgloadedinfo]} { - puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available" + puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available" lassign $pkgloadedinfo path name set lcpath [string tolower $path] #first attempt to find a match for our loaded sharedlib path in a *simple* package ifneeded statement. @@ -219,7 +219,7 @@ tcl::namespace::eval punk::packagepreference { if {[dict exists $lcpath_to_version $lcpath]} { set lversion [dict get $lcpath_to_version $lcpath] - } else { + } else { #fallback to a best effort guess based on the path set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $path $pkg] } @@ -271,13 +271,13 @@ tcl::namespace::eval punk::packagepreference { #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[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" + # return "ok" #} @@ -296,14 +296,14 @@ tcl::namespace::eval punk::packagepreference::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::packagepreference::lib}] - #[para] Secondary functions that are part of the API + #[para] Secondary functions that are part of the API #[list_begin definitions] #proc utility1 {p1 args} { # #*** !doctools # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 + # #[para]Description of utility1 + # return 1 #} @@ -321,7 +321,7 @@ tcl::namespace::eval punk::packagepreference::lib { tcl::namespace::eval punk::packagepreference::system { #*** !doctools #[subsection {Namespace punk::packagepreference::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API variable PUNKARGS lappend PUNKARGS [list { @@ -330,8 +330,8 @@ tcl::namespace::eval punk::packagepreference::system { "Assistance function to determine pkg version from the information obtained from [info loaded]. This is used to try to avoid loading a different version of a binary package in another thread/interp when the package isn't - present in the interp, but [info loaded] indicates the binary is already loaded. - The more general/robust way to avoid this is to ensure ::auto_path and + present in the interp, but [info loaded] indicates the binary is already loaded. + The more general/robust way to avoid this is to ensure ::auto_path and tcl::tm::list are the same in each interp/thread. This call should only be used as a fallback in case a binary package has a more @@ -348,8 +348,8 @@ tcl::namespace::eval punk::packagepreference::system { The filename itself is first checked for a version number - but the number is ignored if it doesn't contain any dots. (prefix is checked to match with $pkgname, with a possible additional prefix - of lib or tcl) - Often (even usually) the parent or grandparent folder will be named as + of lib or tcl) + Often (even usually) the parent or grandparent folder will be named as per the package name with a proper version. If so we can return it, otherwise return empty string. The parent/grandparent matching will be done by looking for a case @@ -395,7 +395,7 @@ tcl::namespace::eval punk::packagepreference::system { } } #review - sometimes path and lib are named only for major.minor but package provides major.minor.subversion - #using returned val to attempt to package require -exact major.minor will fail to load major.minor.subversion + #using returned val to attempt to package require -exact major.minor will fail to load major.minor.subversion return "" } @@ -407,11 +407,11 @@ namespace eval ::punk::args::register { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { variable pkg punk::packagepreference variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm index 1ddd56b7..ff48fcb0 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm @@ -703,6 +703,11 @@ namespace eval punk::path { set opt_dir [dict get $opts -directory] } + #comment out to compare timings with treefilenames_zipfs + if {[string match //zipfs:/* $opt_dir]} { + return [treefilenames_zipfs {*}$args] + } + set skip 0 foreach anti $opt_antiglob_paths { if {[globmatchpath $anti $opt_dir]} { @@ -762,6 +767,138 @@ namespace eval punk::path { } return $files } + proc treefilenames_zipfs {args} { + #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW + # is sort order the same? + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + lassign [dict values $argd] leaders opts values received + set tailglobs [dict get $values tailglobs] + # -- --- --- --- --- --- --- + set opt_antiglob_paths [dict get $opts -antiglob_paths] + set opt_antiglob_files [dict get $opts -antiglob_files] + set CALLDEPTH [dict get $opts -call-depth-internal] + # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- + + set files [list] + if {$CALLDEPTH == 0} { + #set opts [dict merge $opts [list -directory $opt_dir]] + if {![dict exists $received -directory]} { + set opt_dir [pwd] + } else { + set opt_dir [dict get $opts -directory] + } + if {![file isdirectory $opt_dir]} { + return [list] + } + } else { + #assume/require to exist in any recursive call + set opt_dir [dict get $opts -directory] + } + if {![string match [zipfs root]* $opt_dir]} { + error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" + } + set dir [string trimright $opt_dir "/"] ;#e.g normalize //zipfs:/x/ to //zipfs:/x + set dirlen [string length $dir] + + set skip 0 + foreach anti $opt_antiglob_paths { + if {[globmatchpath $anti $dir]} { + set skip 1 + break + } + } + if {$skip} { + return [list] + } + set subpaths [zipfs list $dir/*] + set dirlist [list] + set skipdirs [list] + set filelist [list] + #process in the order they came - sorting large list more expensive?? review + foreach sub $subpaths { + set tail [string range $sub $dirlen+1 end] ;#dirlen is without trailing slash + set tailparts [file split $tail] + set accum "" + set skipdir 0 + foreach tp [lrange $tailparts 0 end-1] { + append accum "/$tp" + set superpath "${dir}${accum}" + if {$superpath in $skipdirs} { + #subpart already in skipdirs + set skipdir 1 + break + } + if {$superpath ni $dirlist} { + set skip2 0 + foreach anti $opt_antiglob_paths { + if {[globmatchpath $anti $superpath]} { + set skip2 1 + lappend skipdirs $superpath + break + } + } + if {!$skip2} { + lappend dirlist $superpath + } else { + set skipdir 1 + break + } + } + } + if {!$skipdir} { + #process final part of path + append accum "/[lindex $tailparts end]" + set finalpart "${dir}${accum}" + if {$finalpart ni $dirlist} { + if {[file type $finalpart] eq "file"} { + set ftail [lindex $tailparts end] + set match 0 + if {"*" ni $tailglobs} { + foreach tg $tailglobs { + if {[string match $tg $ftail]} { + set match 1 + break + } + } + } else { + set match 1 + } + if {$match} { + if {[llength $opt_antiglob_files]} { + set skipfile 0 + foreach anti $opt_antiglob_files { + if {[string match $anti $ftail]} { + set skipfile 1; break + } + } + if {!$skipfile} { + lappend filelist $finalpart + } + } else { + lappend filelist $finalpart + } + } + } else { + if {$finalpart ni $dirlist} { + set skip2 0 + foreach anti $opt_antiglob_paths { + if {[globmatchpath $anti $finalpart]} { + set skip2 1 + lappend skipdirs $finalpart + break + } + } + if {!$skip2} { + lappend dirlist $finalpart + } + } + } + } + } + } + return $filelist + } #maint warning - also in punkcheck proc relative {reference location} { 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 a99a7805..26f92ae5 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,7 +20,18 @@ 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} + } + } +} @@ -2707,6 +2718,18 @@ 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} + } + } + } package require punk::packagepreference punk::packagepreference::install @@ -3090,7 +3113,7 @@ namespace eval repl { set nsquals [namespace qualifiers $pkg] if {$nsquals ne ""} { if {![dict exists $ns_scanned $nsquals]} { - catch {package require ${nsquals}::flubber_nonexistant} ;#force scan + catch {package require $pkg 1-0} ;#force scan with nonsatisfiable version dict set ns_scanned $nsquals 1 } } @@ -3341,6 +3364,20 @@ 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} + } + } + } + # -- --- #review #we have to blow some time on a rescan to provide more deterministic ordering (match behaviour of initial thread regarding pkg precedence) @@ -3348,12 +3385,16 @@ namespace eval repl { ##catch {package require flobrudder-nonexistant} # -- --- + set tsstart [clock millis] if {[catch { package require vfs package require vfs::zip } errM]} { - puts stderr "repl code interp can't load vfs,vfs::zip" + puts stderr "repl code interp FAILED to load vfs,vfs::zip lag:[expr {[clock millis] - $tsstart}]" + } else { + puts stderr "repl code interp loaded vfs,vfs::zip lag:[expr {[clock millis] - $tsstart}]" } + puts stderr "package unknown: [package unknown]" #puts stderr ----- #puts stderr [join $::auto_path \n] 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 new file mode 100644 index 00000000..e69de29b