38 changed files with 1750 additions and 205 deletions
@ -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 |
||||||
|
|
||||||
@ -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 |
||||||
@ -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] |
||||||
|
|
||||||
@ -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 <organization>. The name of the |
|
||||||
<organization> 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. |
|
||||||
@ -1,2 +0,0 @@ |
|||||||
package ifneeded zint 2.13.0\ |
|
||||||
[list load [file join $dir zint[info sharedlibextension]]] |
|
||||||
@ -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. |
|
||||||
Binary file not shown.
Loading…
Reference in new issue