136 changed files with 96844 additions and 43154 deletions
@ -1,705 +0,0 @@ |
|||||||
# -*- tcl -*- |
|
||||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
||||||
# |
|
||||||
# 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) 2024 |
|
||||||
# |
|
||||||
# @@ Meta Begin |
|
||||||
# Application modpod 0.1.0 |
|
||||||
# Meta platform tcl |
|
||||||
# Meta license <unspecified> |
|
||||||
# @@ Meta End |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# doctools header |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
#*** !doctools |
|
||||||
#[manpage_begin modpod_module_modpod 0 0.1.0] |
|
||||||
#[copyright "2024"] |
|
||||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
|
||||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
|
||||||
#[require modpod] |
|
||||||
#[keywords module] |
|
||||||
#[description] |
|
||||||
#[para] - |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[section Overview] |
|
||||||
#[para] overview of modpod |
|
||||||
#[subsection Concepts] |
|
||||||
#[para] - |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
## Requirements |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[subsection dependencies] |
|
||||||
#[para] packages used by modpod |
|
||||||
#[list_begin itemized] |
|
||||||
|
|
||||||
package require Tcl 8.6- |
|
||||||
package require struct::set ;#review |
|
||||||
package require punk::lib |
|
||||||
package require punk::args |
|
||||||
#*** !doctools |
|
||||||
#[item] [package {Tcl 8.6-}] |
|
||||||
|
|
||||||
# #package require frobz |
|
||||||
# #*** !doctools |
|
||||||
# #[item] [package {frobz}] |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[section API] |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# oo::class namespace |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
namespace eval modpod::class { |
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace modpod::class}] |
|
||||||
#[para] class definitions |
|
||||||
if {[info commands [namespace current]::interface_sample1] eq ""} { |
|
||||||
#*** !doctools |
|
||||||
#[list_begin enumerated] |
|
||||||
|
|
||||||
# oo::class create interface_sample1 { |
|
||||||
# #*** !doctools |
|
||||||
# #[enum] CLASS [class interface_sample1] |
|
||||||
# #[list_begin definitions] |
|
||||||
|
|
||||||
# method test {arg1} { |
|
||||||
# #*** !doctools |
|
||||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
|
||||||
# #[para] test method |
|
||||||
# puts "test: $arg1" |
|
||||||
# } |
|
||||||
|
|
||||||
# #*** !doctools |
|
||||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
|
||||||
# } |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] [comment {--- end class enumeration ---}] |
|
||||||
} |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# Base namespace |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
namespace eval modpod { |
|
||||||
namespace export {[a-z]*}; # Convention: export all lowercase |
|
||||||
|
|
||||||
variable connected |
|
||||||
if {![info exists connected(to)]} { |
|
||||||
set connected(to) list |
|
||||||
} |
|
||||||
variable modpodscript |
|
||||||
set modpodscript [info script] |
|
||||||
if {[string tolower [file extension $modpodscript]] eq ".tcl"} { |
|
||||||
set connected(self) [file dirname $modpodscript] |
|
||||||
} else { |
|
||||||
#expecting a .tm |
|
||||||
set connected(self) $modpodscript |
|
||||||
} |
|
||||||
variable loadables [info sharedlibextension] |
|
||||||
variable sourceables {.tcl .tk} ;# .tm ? |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace modpod}] |
|
||||||
#[para] Core API functions for modpod |
|
||||||
#[list_begin definitions] |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#proc sample1 {p1 args} { |
|
||||||
# #*** !doctools |
|
||||||
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
|
||||||
# #[para]Description of sample1 |
|
||||||
# return "ok" |
|
||||||
#} |
|
||||||
|
|
||||||
proc connect {args} { |
|
||||||
puts stderr "modpod::connect--->>$args" |
|
||||||
set argd [punk::args::get_dict { |
|
||||||
-type -default "" |
|
||||||
*values -min 1 -max 1 |
|
||||||
path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" |
|
||||||
} $args] |
|
||||||
catch { |
|
||||||
punk::lib::showdict $argd ;#heavy dependencies |
|
||||||
} |
|
||||||
set opt_path [dict get $argd values path] |
|
||||||
variable connected |
|
||||||
set original_connectpath $opt_path |
|
||||||
set modpodpath [modpod::system::normalize $opt_path] ;# |
|
||||||
|
|
||||||
if {$modpodpath in $connected(to)} { |
|
||||||
return [dict create ok ALREADY_CONNECTED] |
|
||||||
} |
|
||||||
lappend connected(to) $modpodpath |
|
||||||
|
|
||||||
set connected(connectpath,$opt_path) $original_connectpath |
|
||||||
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info_script]]}] |
|
||||||
|
|
||||||
set connected(location,$modpodpath) [file dirname $modpodpath] |
|
||||||
set connected(startdata,$modpodpath) -1 |
|
||||||
set connected(type,$modpodpath) [dict get $argd-opts -type] |
|
||||||
set connected(fh,$modpodpath) "" |
|
||||||
|
|
||||||
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { |
|
||||||
set connected(type,$modpodpath) "unwrapped" |
|
||||||
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
|
||||||
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] |
|
||||||
|
|
||||||
} else { |
|
||||||
#connect to .tm but may still be unwrapped version available |
|
||||||
lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
|
||||||
set this_pkg_tm_folder [file dirname $modpodpath] |
|
||||||
if {$connected(type,$modpodpath) ne "unwrapped"} { |
|
||||||
#Not directly connected to unwrapped version - but may still be redirected there |
|
||||||
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] |
|
||||||
if {[file exists $unwrappedFolder]} { |
|
||||||
#folder with exact version-match must exist for redirect to 'unwrapped' |
|
||||||
set con(type,$modpodpath) "modpod-redirecting" |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
} |
|
||||||
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" |
|
||||||
set connected(tmfile,$modpodpath) |
|
||||||
set tail_segments [list] |
|
||||||
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] |
|
||||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
|
||||||
foreach lc_mpath $lcase_modulepaths { |
|
||||||
set mpath_segments [file split $lc_mpath] |
|
||||||
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
|
||||||
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
if {[llength $tail_segments]} { |
|
||||||
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require |
|
||||||
} else { |
|
||||||
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] |
|
||||||
} |
|
||||||
|
|
||||||
switch -exact -- $connected(type,$modpodpath) { |
|
||||||
"modpod-redirecting" { |
|
||||||
#redirect to the unwrapped version |
|
||||||
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] |
|
||||||
|
|
||||||
} |
|
||||||
"unwrapped" { |
|
||||||
if {[info commands ::thread::id] ne ""} { |
|
||||||
set from [pid],[thread::id] |
|
||||||
} else { |
|
||||||
set from [pid] |
|
||||||
} |
|
||||||
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" |
|
||||||
return [list ok ""] |
|
||||||
} |
|
||||||
default { |
|
||||||
#autodetect .tm - zip/tar ? |
|
||||||
#todo - use vfs ? |
|
||||||
|
|
||||||
#connect to tarball - start at 1st header |
|
||||||
set connected(startdata,$modpodpath) 0 |
|
||||||
set fh [open $modpodpath r] |
|
||||||
set connected(fh,$modpodpath) $fh |
|
||||||
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} |
|
||||||
|
|
||||||
if {$connected(startdata,$modpodpath) >= 0} { |
|
||||||
#verify we have a valid tar header |
|
||||||
if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { |
|
||||||
seek $fh $connected(startdata,$modpodpath) start |
|
||||||
return [list ok $fh] |
|
||||||
} else { |
|
||||||
#error "cannot verify tar header" |
|
||||||
} |
|
||||||
} |
|
||||||
lpop connected(to) end |
|
||||||
set connected(startdata,$modpodpath) -1 |
|
||||||
unset connected(fh,$modpodpath) |
|
||||||
catch {close $fh} |
|
||||||
return [dict create err {Does not appear to be a valid modpod}] |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
proc disconnect {{modpod ""}} { |
|
||||||
variable connected |
|
||||||
if {![llength $connected(to)]} { |
|
||||||
return 0 |
|
||||||
} |
|
||||||
if {$modpod eq ""} { |
|
||||||
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" |
|
||||||
set modpod [lindex $connected(to) end] |
|
||||||
} |
|
||||||
|
|
||||||
if {[set posn [lsearch $connected(to) $modpod]] == -1} { |
|
||||||
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" |
|
||||||
return 0 |
|
||||||
} |
|
||||||
if {[string length $connected(fh,$modpod)]} { |
|
||||||
close $connected(fh,$modpod) |
|
||||||
} |
|
||||||
array unset connected *,$modpod |
|
||||||
set connected(to) [lreplace $connected(to) $posn $posn] |
|
||||||
return 1 |
|
||||||
} |
|
||||||
proc get {args} { |
|
||||||
set argd [punk::args::get_dict { |
|
||||||
-from -default "" -help "path to pod" |
|
||||||
*values -min 1 -max 1 |
|
||||||
filename |
|
||||||
} $args] |
|
||||||
set frompod [dict get $argd opts -from] |
|
||||||
set filename [dict get $argd values filename] |
|
||||||
|
|
||||||
variable connected |
|
||||||
set modpod [::tarjar::system::connect_if_not $frompod] |
|
||||||
set fh $connected(fh,$modpod) |
|
||||||
if {$connected(type,$modpod) eq "unwrapped"} { |
|
||||||
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder |
|
||||||
if {[string range $filename 0 0 eq "/"]} { |
|
||||||
#absolute path (?) |
|
||||||
set path [file join $connected(location,$modpod) .. [string trim $filename /]] |
|
||||||
} else { |
|
||||||
#relative path - use #modpod-xxx as base |
|
||||||
set path [file join $connected(location,$modpod) $filename] |
|
||||||
} |
|
||||||
set fd [open $path r] |
|
||||||
#utf-8? |
|
||||||
#fconfigure $fd -encoding iso8859-1 -translation binary |
|
||||||
return [list ok [lindex [list [read $fd] [close $fd]] 0]] |
|
||||||
} else { |
|
||||||
#read from vfs |
|
||||||
puts stderr "get $filename from wrapped pod '$frompod' not implemented" |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] [comment {--- end definitions namespace modpod ---}] |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# Secondary API namespace |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
namespace eval modpod::lib { |
|
||||||
namespace export {[a-z]*}; # Convention: export all lowercase |
|
||||||
namespace path [namespace parent] |
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace modpod::lib}] |
|
||||||
#[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 |
|
||||||
#} |
|
||||||
|
|
||||||
proc is_valid_tm_version {versionpart} { |
|
||||||
#Needs to be suitable for use with Tcl's 'package vcompare' |
|
||||||
if {![catch [list package vcompare $versionparts $versionparts]]} { |
|
||||||
return 1 |
|
||||||
} else { |
|
||||||
return 0 |
|
||||||
} |
|
||||||
} |
|
||||||
proc make_zip_modpod {zipfile outfile} { |
|
||||||
set mount_stub { |
|
||||||
#zip file with Tcl loader prepended. |
|
||||||
#generated using modpod::make_zip_modpod |
|
||||||
if {[catch {file normalize [info script]} modfile]} { |
|
||||||
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
|
||||||
} |
|
||||||
if {$modfile eq "" || ![file exists $modfile]} { |
|
||||||
error "modpod zip stub error. Unable to determine module path" |
|
||||||
} |
|
||||||
set moddir [file dirname $modfile] |
|
||||||
set mod_and_ver [file rootname [file tail $modfile]] |
|
||||||
lassign [split $mod_and_ver -] moduletail version |
|
||||||
if {[file exists $moddir/#modpod-$mod_and_ver]} { |
|
||||||
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm |
|
||||||
} else { |
|
||||||
#determine module namespace so we can mount appropriately |
|
||||||
proc intersect {A B} { |
|
||||||
if {[llength $A] == 0} {return {}} |
|
||||||
if {[llength $B] == 0} {return {}} |
|
||||||
if {[llength $B] > [llength $A]} { |
|
||||||
set res $A |
|
||||||
set A $B |
|
||||||
set B $res |
|
||||||
} |
|
||||||
set res {} |
|
||||||
foreach x $A {set ($x) {}} |
|
||||||
foreach x $B { |
|
||||||
if {[info exists ($x)]} { |
|
||||||
lappend res $x |
|
||||||
} |
|
||||||
} |
|
||||||
return $res |
|
||||||
} |
|
||||||
set lcase_tmfile_segments [string tolower [file split $moddir]] |
|
||||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
|
||||||
foreach lc_mpath $lcase_modulepaths { |
|
||||||
set mpath_segments [file split $lc_mpath] |
|
||||||
if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
|
||||||
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use propertly cased tail |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
if {[llength $tail_segments]} { |
|
||||||
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require |
|
||||||
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver |
|
||||||
} else { |
|
||||||
set fullpackage $moduletail |
|
||||||
set mount_at #modpod/#mounted-modpod-$mod_and_ver |
|
||||||
} |
|
||||||
|
|
||||||
if {[info commands tcl::zipfs::mount] ne ""} { |
|
||||||
#argument order changed to be consistent with vfs::zip::Mount etc |
|
||||||
#early versions: zipfs::Mount mountpoint zipname |
|
||||||
#since 2023-09: zipfs::Mount zipname mountpoint |
|
||||||
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) |
|
||||||
#This is presumably related to // being interpreted as a network path |
|
||||||
set mountpoints [dict keys [tcl::zipfs::mount]] |
|
||||||
if {"//zipfs:/$mount_at" ni $mountpoints} { |
|
||||||
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it |
|
||||||
if {[catch { |
|
||||||
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) |
|
||||||
#puts "tcl::zipfs::mount $modfile $mount_at" |
|
||||||
tcl::zipfs::mount $modfile $mount_at |
|
||||||
} errM]} { |
|
||||||
#try old api |
|
||||||
if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { |
|
||||||
puts stderr "modpod stub>>> tcl::zipfs::mount <file> <mountpoint> failed.\nbut old api: tcl::zipfs::mount <mountpoint> <file> succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" |
|
||||||
puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" |
|
||||||
} |
|
||||||
} |
|
||||||
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
|
||||||
puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" |
|
||||||
#tcl::zipfs::unmount //zipfs:/$mount_at |
|
||||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
|
||||||
} |
|
||||||
} |
|
||||||
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form |
|
||||||
source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
|
||||||
} else { |
|
||||||
#fallback to slower vfs::zip |
|
||||||
#NB. We don't create the intermediate dirs - but the mount still works |
|
||||||
if {![file exists $moddir/$mount_at]} { |
|
||||||
if {[catch {package require vfs::zip} errM]} { |
|
||||||
set msg "Unable to load vfs::zip package to mount module $mod_and_ver" |
|
||||||
append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place." |
|
||||||
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" |
|
||||||
error $msg |
|
||||||
} else { |
|
||||||
set fd [vfs::zip::Mount $modfile $moddir/$mount_at] |
|
||||||
if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
|
||||||
vfs::zip::Unmount $fd $moddir/$mount_at |
|
||||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
|
||||||
} |
|
||||||
} |
|
||||||
#zipped data follows |
|
||||||
} |
|
||||||
#todo - test if zipfile has #modpod-loadcript.tcl before even creating |
|
||||||
append mount_stub \x1A |
|
||||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub |
|
||||||
|
|
||||||
} |
|
||||||
proc make_zip_modpod1 {zipfile outfile} { |
|
||||||
set mount_stub { |
|
||||||
#zip file with Tcl loader prepended. |
|
||||||
#generated using modpod::make_zip_modpod |
|
||||||
if {[catch {file normalize [info script]} modfile]} { |
|
||||||
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
|
||||||
} |
|
||||||
if {$modfile eq "" || ![file exists $modfile]} { |
|
||||||
error "modpod zip stub error. Unable to determine module path" |
|
||||||
} |
|
||||||
set moddir [file dirname $modfile] |
|
||||||
set mod_and_ver [file rootname [file tail $modfile]] |
|
||||||
lassign [split $mod_and_ver -] moduletail version |
|
||||||
if {[file exists $moddir/#modpod-$mod_and_ver]} { |
|
||||||
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm |
|
||||||
} else { |
|
||||||
if {![file exists $moddir/#mounted-modpod-$mod_and_ver]} { |
|
||||||
if {[catch {package require vfs::zip} errM]} { |
|
||||||
set msg "Unable to load vfs::zip package to mount module $mod_and_ver" |
|
||||||
append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place." |
|
||||||
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $ |
|
||||||
} |
|
||||||
set fd [vfs::zip::Mount $modfile $moddir/#mounted-modpod-$mod_and_ver] |
|
||||||
if {![file exists $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
|
||||||
vfs::zip::Unmount $fd $moddir/#mounted-modpod-$mod_and_ver |
|
||||||
error "Unable to find #modpod-$mod_and_ver/$mod_and_ver.tm in $modfile" |
|
||||||
} |
|
||||||
} |
|
||||||
source $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm |
|
||||||
} |
|
||||||
#zipped data follows |
|
||||||
} |
|
||||||
#todo - test if zipfile has #modpod-loadcript.tcl before even creating |
|
||||||
append mount_stub \x1A |
|
||||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub |
|
||||||
|
|
||||||
} |
|
||||||
proc make_zip_source_mountable {zipfile outfile} { |
|
||||||
set mount_stub { |
|
||||||
package require vfs::zip |
|
||||||
vfs::zip::Mount [info script] [info script] |
|
||||||
} |
|
||||||
append mount_stub \x1A |
|
||||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub |
|
||||||
} |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] [comment {--- end definitions namespace modpod::lib ---}] |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
#*** !doctools |
|
||||||
#[section Internal] |
|
||||||
namespace eval modpod::system { |
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace modpod::system}] |
|
||||||
#[para] Internal functions that are not part of the API |
|
||||||
|
|
||||||
#deflate,store only supported |
|
||||||
proc make_mountable_zip {zipfile outfile mount_stub} { |
|
||||||
set in [open $zipfile r] |
|
||||||
fconfigure $in -encoding iso8859-1 -translation binary |
|
||||||
set out [open $outfile w+] |
|
||||||
fconfigure $out -encoding iso8859-1 -translation binary |
|
||||||
puts -nonewline $out $mount_stub |
|
||||||
set offset [tell $out] |
|
||||||
lappend report "sfx stub size: $offset" |
|
||||||
fcopy $in $out |
|
||||||
|
|
||||||
close $in |
|
||||||
set size [tell $out] |
|
||||||
#Now seek in $out to find the end of directory signature: |
|
||||||
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text |
|
||||||
if {$size < 65559} { |
|
||||||
set seek 0 |
|
||||||
} else { |
|
||||||
set seek [expr {$size - 65559}] |
|
||||||
} |
|
||||||
seek $out $seek |
|
||||||
set data [read $out] |
|
||||||
set start_of_end [string last "\x50\x4b\x05\x06" $data] |
|
||||||
#set start_of_end [expr {$start_of_end + $seek}] |
|
||||||
incr start_of_end $seek |
|
||||||
|
|
||||||
lappend report "START-OF-END: $start_of_end ([expr {$start_of_end - $size}]) [string length $data]" |
|
||||||
|
|
||||||
seek $out $start_of_end |
|
||||||
set end_of_ctrl_dir [read $out] |
|
||||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
|
||||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
|
||||||
|
|
||||||
lappend report "End of central directory: [array get eocd]" |
|
||||||
seek $out [expr {$start_of_end+16}] |
|
||||||
|
|
||||||
#adjust offset of start of central directory by the length of our sfx stub |
|
||||||
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $offset}]] |
|
||||||
flush $out |
|
||||||
|
|
||||||
seek $out $start_of_end |
|
||||||
set end_of_ctrl_dir [read $out] |
|
||||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
|
||||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
|
||||||
|
|
||||||
# 0x06054b50 - end of central dir signature |
|
||||||
puts stderr "$end_of_ctrl_dir" |
|
||||||
puts stderr "comment_len: $eocd(comment_len)" |
|
||||||
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" |
|
||||||
lappend report "New dir offset: $eocd(diroffset)" |
|
||||||
lappend report "Adjusting $eocd(totalnum) zip file items." |
|
||||||
catch { |
|
||||||
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies |
|
||||||
} |
|
||||||
|
|
||||||
seek $out $eocd(diroffset) |
|
||||||
for {set i 0} {$i <$eocd(totalnum)} {incr i} { |
|
||||||
set current_file [tell $out] |
|
||||||
set fileheader [read $out 46] |
|
||||||
puts -------------- |
|
||||||
puts [ansistring VIEW -lf 1 $fileheader] |
|
||||||
puts -------------- |
|
||||||
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
|
||||||
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
|
||||||
|
|
||||||
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
|
||||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
|
||||||
set ::last_header $fileheader |
|
||||||
|
|
||||||
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" |
|
||||||
puts "ver: $x(version)" |
|
||||||
puts "method: $x(method)" |
|
||||||
|
|
||||||
#33639248 dec = 0x02014b50 - central file header signature |
|
||||||
if { $x(sig) != 33639248 } { |
|
||||||
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" |
|
||||||
} |
|
||||||
|
|
||||||
foreach size $x(lengths) var {filename extrafield comment} { |
|
||||||
if { $size > 0 } { |
|
||||||
set x($var) [read $out $size] |
|
||||||
} else { |
|
||||||
set x($var) "" |
|
||||||
} |
|
||||||
} |
|
||||||
set next_file [tell $out] |
|
||||||
lappend report "file $i: $x(offset) $x(sizes) $x(filename)" |
|
||||||
|
|
||||||
seek $out [expr {$current_file+42}] |
|
||||||
puts -nonewline $out [binary format i [expr {$x(offset)+$offset}]] |
|
||||||
|
|
||||||
#verify: |
|
||||||
flush $out |
|
||||||
seek $out $current_file |
|
||||||
set fileheader [read $out 46] |
|
||||||
lappend report "old $x(offset) + $offset" |
|
||||||
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
|
||||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
|
||||||
lappend report "new $x(offset)" |
|
||||||
|
|
||||||
seek $out $next_file |
|
||||||
} |
|
||||||
close $out |
|
||||||
#pdict/showdict reuire punk & textlib - ie lots of dependencies |
|
||||||
#don't fall over just because of that |
|
||||||
catch { |
|
||||||
punk::lib::showdict -roottype list -chan stderr $report |
|
||||||
} |
|
||||||
#puts [join $report \n] |
|
||||||
return |
|
||||||
} |
|
||||||
|
|
||||||
proc connect_if_not {{podpath ""}} { |
|
||||||
upvar ::modpod::connected connected |
|
||||||
set podpath [::modpod::system::normalize $podpath] |
|
||||||
set docon 0 |
|
||||||
if {![llength $connected(to)]} { |
|
||||||
if {![string length $podpath]} { |
|
||||||
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" |
|
||||||
} else { |
|
||||||
set docon 1 |
|
||||||
} |
|
||||||
} else { |
|
||||||
if {![string length $podpath]} { |
|
||||||
set podpath [lindex $connected(to) end] |
|
||||||
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" |
|
||||||
} else { |
|
||||||
if {$podpath ni $connected(to)} { |
|
||||||
set docon 1 |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
if {$docon} { |
|
||||||
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { |
|
||||||
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" |
|
||||||
} else { |
|
||||||
return $podpath |
|
||||||
} |
|
||||||
} |
|
||||||
#we were already connected |
|
||||||
return $podpath |
|
||||||
} |
|
||||||
|
|
||||||
proc myversion {} { |
|
||||||
upvar ::modpod::connected connected |
|
||||||
set script [info script] |
|
||||||
if {![string length $script]} { |
|
||||||
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" |
|
||||||
} |
|
||||||
set fname [file tail [file rootname [file normalize $script]]] |
|
||||||
set scriptdir [file dirname $script] |
|
||||||
|
|
||||||
if {![string match "#modpod-*" $fname]} { |
|
||||||
lassign [lrange [split $fname -] end-1 end] _pkgname version |
|
||||||
} else { |
|
||||||
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version |
|
||||||
if {![string length $version]} { |
|
||||||
#try again on the name of the containing folder |
|
||||||
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version |
|
||||||
#todo - proper walk up the directory tree |
|
||||||
if {![string length $version]} { |
|
||||||
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) |
|
||||||
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
#tarjar::Log debug "'myversion' determined version for [info script]: $version" |
|
||||||
return $version |
|
||||||
} |
|
||||||
|
|
||||||
proc myname {} { |
|
||||||
upvar ::modpod::connected connected |
|
||||||
set script [info script] |
|
||||||
if {![string length $script]} { |
|
||||||
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" |
|
||||||
} |
|
||||||
return $connected(fullpackage,$script) |
|
||||||
} |
|
||||||
proc myfullname {} { |
|
||||||
upvar ::modpod::connected connected |
|
||||||
set script [info script] |
|
||||||
#set script [::tarjar::normalize $script] |
|
||||||
set script [file normalize $script] |
|
||||||
if {![string length $script]} { |
|
||||||
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" |
|
||||||
} |
|
||||||
return $::tarjar::connected(fullpackage,$script) |
|
||||||
} |
|
||||||
proc normalize {path} { |
|
||||||
#newer versions of Tcl don't do tilde sub |
|
||||||
|
|
||||||
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) |
|
||||||
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. |
|
||||||
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. |
|
||||||
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after |
|
||||||
set path [file normalize $path] |
|
||||||
#set path [string tolower $path] ;#must do this after file normalize |
|
||||||
return [string map [list $matilda ~] $path] ;#get our tildes back. |
|
||||||
} |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
## Ready |
|
||||||
package provide modpod [namespace eval modpod { |
|
||||||
variable pkg modpod |
|
||||||
variable version |
|
||||||
set version 0.1.0 |
|
||||||
}] |
|
||||||
return |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[manpage_end] |
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -1,7 +0,0 @@ |
|||||||
::lindex tcl;#\ |
|
||||||
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
|
||||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
|
||||||
puts stdout "script: [info script]" |
|
||||||
puts stdout "argv: $::argc" |
|
||||||
puts stdout "args: '$::argv'" |
|
||||||
|
|
||||||
Binary file not shown.
Binary file not shown.
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,259 @@ |
|||||||
|
|
||||||
|
# Tcl parser for optional arguments in function calls and |
||||||
|
# commandline arguments |
||||||
|
# |
||||||
|
# (c) 2001 Bastien Chevreux |
||||||
|
|
||||||
|
# Index of exported commands |
||||||
|
# - argp::registerArgs |
||||||
|
# - argp::setArgDefaults |
||||||
|
# - argp::setArgsNeeded |
||||||
|
# - argp::parseArgs |
||||||
|
|
||||||
|
# Internal commands |
||||||
|
# - argp::CheckValues |
||||||
|
|
||||||
|
# See end of file for an example on how to use |
||||||
|
|
||||||
|
package provide argp 0.2 |
||||||
|
|
||||||
|
namespace eval argp { |
||||||
|
variable Optstore |
||||||
|
variable Opttypes { |
||||||
|
boolean integer double string |
||||||
|
} |
||||||
|
|
||||||
|
namespace export {[a-z]*} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc argp::registerArgs { func arglist } { |
||||||
|
variable Opttypes |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||||
|
if { $parentns != "" } { |
||||||
|
append caller $parentns :: $func |
||||||
|
} else { |
||||||
|
set caller $func |
||||||
|
} |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
|
||||||
|
#puts $parentns |
||||||
|
#puts $caller |
||||||
|
#puts $cmangled |
||||||
|
|
||||||
|
set Optstore(keys,$cmangled) {} |
||||||
|
set Optstore(deflist,$cmangled) {} |
||||||
|
set Optstore(argneeded,$cmangled) {} |
||||||
|
|
||||||
|
foreach arg $arglist { |
||||||
|
foreach {opt type default allowed} $arg { |
||||||
|
set optindex [lsearch -glob $Opttypes $type*] |
||||||
|
if { $optindex < 0} { |
||||||
|
return -code error "$caller, unknown type $type while registering arguments.\nAllowed types: [string trim $Opttypes]" |
||||||
|
} |
||||||
|
set type [lindex $Opttypes $optindex] |
||||||
|
|
||||||
|
lappend Optstore(keys,$cmangled) $opt |
||||||
|
set Optstore(type,$opt,$cmangled) $type |
||||||
|
set Optstore(default,$opt,$cmangled) $default |
||||||
|
set Optstore(allowed,$opt,$cmangled) $allowed |
||||||
|
lappend Optstore(deflist,$cmangled) $opt $default |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if { [catch {CheckValues $caller $cmangled $Optstore(deflist,$cmangled)} res]} { |
||||||
|
return -code error "Error in declaration of optional arguments.\n$res" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc argp::setArgDefaults { func arglist } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||||
|
if { $parentns != "" } { |
||||||
|
append caller $parentns :: $func |
||||||
|
} else { |
||||||
|
set caller $func |
||||||
|
} |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
|
||||||
|
if {![info exists Optstore(deflist,$cmangled)]} { |
||||||
|
return -code error "Arguments for $caller not registered yet." |
||||||
|
} |
||||||
|
set Optstore(deflist,$cmangled) {} |
||||||
|
foreach {opt default} $arglist { |
||||||
|
if {![info exists Optstore(default,$opt,$cmangled)]} { |
||||||
|
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" |
||||||
|
} |
||||||
|
set Optstore(default,$opt,$cmangled) $default |
||||||
|
} |
||||||
|
|
||||||
|
# set the new defaultlist |
||||||
|
foreach opt $Optstore(keys,$cmangled) { |
||||||
|
lappend Optstore(deflist,$cmangled) $opt $Optstore(default,$opt,$cmangled) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc argp::setArgsNeeded { func arglist } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||||
|
if { $parentns != "" } { |
||||||
|
append caller $parentns :: $func |
||||||
|
} else { |
||||||
|
set caller $func |
||||||
|
} |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
|
||||||
|
#append caller $parentns :: $func |
||||||
|
#set cmangled ${parentns}_$func |
||||||
|
|
||||||
|
if {![info exists Optstore(deflist,$cmangled)]} { |
||||||
|
return -code error "Arguments for $caller not registered yet." |
||||||
|
} |
||||||
|
|
||||||
|
set Optstore(argneeded,$cmangled) {} |
||||||
|
foreach opt $arglist { |
||||||
|
if {![info exists Optstore(default,$opt,$cmangled)]} { |
||||||
|
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" |
||||||
|
} |
||||||
|
lappend Optstore(argneeded,$cmangled) $opt |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc argp::parseArgs { args } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
if {[llength $args] == 0} { |
||||||
|
upvar args a opts o |
||||||
|
} else { |
||||||
|
upvar args a [lindex $args 0] o |
||||||
|
} |
||||||
|
|
||||||
|
if { [ catch { set caller [lindex [info level -1] 0]}]} { |
||||||
|
set caller "main program" |
||||||
|
set cmangled "" |
||||||
|
} else { |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
} |
||||||
|
|
||||||
|
if {![info exists Optstore(deflist,$cmangled)]} { |
||||||
|
return -code error "Arguments for $caller not registered yet." |
||||||
|
} |
||||||
|
|
||||||
|
# set the defaults |
||||||
|
array set o $Optstore(deflist,$cmangled) |
||||||
|
|
||||||
|
# but unset the needed arguments |
||||||
|
foreach key $Optstore(argneeded,$cmangled) { |
||||||
|
catch { unset o($key) } |
||||||
|
} |
||||||
|
|
||||||
|
foreach {key val} $a { |
||||||
|
if {![info exists Optstore(type,$key,$cmangled)]} { |
||||||
|
return -code error "$caller, unknown option $key, must be one of: $Optstore(keys,$cmangled)" |
||||||
|
} |
||||||
|
switch -exact -- $Optstore(type,$key,$cmangled) { |
||||||
|
boolean - |
||||||
|
integer { |
||||||
|
if { $val == "" } { |
||||||
|
return -code error "$caller, $key empty string is not $Optstore(type,$key,$cmangled) value." |
||||||
|
} |
||||||
|
if { ![string is $Optstore(type,$key,$cmangled) $val]} { |
||||||
|
return -code error "$caller, $key $val is not $Optstore(type,$key,$cmangled) value." |
||||||
|
} |
||||||
|
} |
||||||
|
double { |
||||||
|
if { $val == "" } { |
||||||
|
return -code error "$caller, $key empty string is not double value." |
||||||
|
} |
||||||
|
if { ![string is double $val]} { |
||||||
|
return -code error "$caller, $key $val is not double value." |
||||||
|
} |
||||||
|
if { [string is integer $val]} { |
||||||
|
set val [expr {$val + .0}] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
} |
||||||
|
} |
||||||
|
set o($key) $val |
||||||
|
} |
||||||
|
|
||||||
|
foreach key $Optstore(argneeded,$cmangled) { |
||||||
|
if {![info exists o($key)]} { |
||||||
|
return -code error "$caller, needed argument $key was not given." |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if { [catch { CheckValues $caller $cmangled [array get o]} err]} { |
||||||
|
return -code error $err |
||||||
|
} |
||||||
|
|
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc argp::CheckValues { caller cmangled checklist } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
#puts "Checking $checklist" |
||||||
|
|
||||||
|
foreach {key val} $checklist { |
||||||
|
if { [llength $Optstore(allowed,$key,$cmangled)] > 0 } { |
||||||
|
switch -exact -- $Optstore(type,$key,$cmangled) { |
||||||
|
string { |
||||||
|
if { [lsearch $Optstore(allowed,$key,$cmangled) $val] < 0} { |
||||||
|
return -code error "$caller, $key $val is not in allowed values: $Optstore(allowed,$key,$cmangled)" |
||||||
|
} |
||||||
|
} |
||||||
|
double - |
||||||
|
integer { |
||||||
|
set found 0 |
||||||
|
foreach range $Optstore(allowed,$key,$cmangled) { |
||||||
|
if {[llength $range] == 1} { |
||||||
|
if { $val == [lindex $range 0] } { |
||||||
|
set found 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} elseif {[llength $range] == 2} { |
||||||
|
set low [lindex $range 0] |
||||||
|
set high [lindex $range 1] |
||||||
|
|
||||||
|
if { ![string is integer $low] \ |
||||||
|
&& [string compare "-" $low] != 0} { |
||||||
|
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a lower value range that is not integer and not \u00b4-\u00b4: $range" |
||||||
|
} |
||||||
|
if { ![string is integer $high] \ |
||||||
|
&& [string compare "+" $high] != 0} { |
||||||
|
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a upper value range that is not integer and not \u00b4+\u00b4: $range" |
||||||
|
} |
||||||
|
if {[string compare "-" $low] == 0} { |
||||||
|
if { [string compare "+" $high] == 0 \ |
||||||
|
|| $val <= $high } { |
||||||
|
set found 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if { $val >= $low } { |
||||||
|
if {[string compare "+" $high] == 0 \ |
||||||
|
|| $val <= $high } { |
||||||
|
set found 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has an allowed value range containing more than 2 elements: $range" |
||||||
|
} |
||||||
|
} |
||||||
|
if { $found == 0 } { |
||||||
|
return -code error "$caller, $key $val is not covered by allowed ranges: $Optstore(allowed,$key,$cmangled)" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
@ -0,0 +1,568 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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) Julian Noble 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application argparsingtest 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin punkshell_module_argparsingtest 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require argparsingtest] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of argparsingtest |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by argparsingtest |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require punk::args |
||||||
|
package require struct::set |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
#[item] [package {punk::args}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval argparsingtest::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace argparsingtest::class}] |
||||||
|
#[para] class definitions |
||||||
|
if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
} |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval argparsingtest { |
||||||
|
namespace export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace argparsingtest}] |
||||||
|
#[para] Core API functions for argparsingtest |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
proc test1_ni {args} { |
||||||
|
set defaults [dict create\ |
||||||
|
-return string\ |
||||||
|
-frametype \uFFEF\ |
||||||
|
-show_edge \uFFEF\ |
||||||
|
-show_seps \uFFEF\ |
||||||
|
-x ""\ |
||||||
|
-y b\ |
||||||
|
-z c\ |
||||||
|
-1 1\ |
||||||
|
-2 2\ |
||||||
|
-3 3\ |
||||||
|
] |
||||||
|
foreach {k v} $args { |
||||||
|
if {$k ni [dict keys $defaults]} { |
||||||
|
error "unrecognised option '$k'. Known options [dict keys $defaults]" |
||||||
|
} |
||||||
|
} |
||||||
|
set opts [dict merge $defaults $args] |
||||||
|
} |
||||||
|
proc test1_switchmerge {args} { |
||||||
|
set defaults [dict create\ |
||||||
|
-return string\ |
||||||
|
-frametype \uFFEF\ |
||||||
|
-show_edge \uFFEF\ |
||||||
|
-show_seps \uFFEF\ |
||||||
|
-x ""\ |
||||||
|
-y b\ |
||||||
|
-z c\ |
||||||
|
-1 1\ |
||||||
|
-2 2\ |
||||||
|
-3 3\ |
||||||
|
] |
||||||
|
foreach {k v} $args { |
||||||
|
switch -- $k { |
||||||
|
-return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 {} |
||||||
|
default { |
||||||
|
error "unrecognised option '$k'. Known options [dict keys $defaults]" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set opts [dict merge $defaults $args] |
||||||
|
} |
||||||
|
#if we need to loop to test arg validity anyway - then dict set as we go is slightly faster than a dict merge at the end |
||||||
|
proc test1_switch {args} { |
||||||
|
set opts [dict create\ |
||||||
|
-return string\ |
||||||
|
-frametype \uFFEF\ |
||||||
|
-show_edge \uFFEF\ |
||||||
|
-show_seps \uFFEF\ |
||||||
|
-x ""\ |
||||||
|
-y b\ |
||||||
|
-z c\ |
||||||
|
-1 1\ |
||||||
|
-2 2\ |
||||||
|
-3 3\ |
||||||
|
] |
||||||
|
foreach {k v} $args { |
||||||
|
switch -- $k { |
||||||
|
-return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { |
||||||
|
dict set opts $k $v |
||||||
|
} |
||||||
|
default { |
||||||
|
error "unrecognised option '$k'. Known options [dict keys $opts]" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $opts |
||||||
|
} |
||||||
|
variable switchopts |
||||||
|
set switchopts [dict create\ |
||||||
|
-return string\ |
||||||
|
-frametype \uFFEF\ |
||||||
|
-show_edge \uFFEF\ |
||||||
|
-show_seps \uFFEF\ |
||||||
|
-x ""\ |
||||||
|
-y b\ |
||||||
|
-z c\ |
||||||
|
-1 1\ |
||||||
|
-2 2\ |
||||||
|
-3 3\ |
||||||
|
] |
||||||
|
#slightly slower than just creating the dict within the proc |
||||||
|
proc test1_switch_nsvar {args} { |
||||||
|
variable switchopts |
||||||
|
set opts $switchopts |
||||||
|
foreach {k v} $args { |
||||||
|
switch -- $k { |
||||||
|
-return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { |
||||||
|
dict set opts $k $v |
||||||
|
} |
||||||
|
default { |
||||||
|
error "unrecognised option '$k'. Known options [dict keys $opts]" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $opts |
||||||
|
} |
||||||
|
proc test1_switch2 {args} { |
||||||
|
set opts [dict create\ |
||||||
|
-return string\ |
||||||
|
-frametype \uFFEF\ |
||||||
|
-show_edge \uFFEF\ |
||||||
|
-show_seps \uFFEF\ |
||||||
|
-x ""\ |
||||||
|
-y b\ |
||||||
|
-z c\ |
||||||
|
-1 1\ |
||||||
|
-2 2\ |
||||||
|
-3 3\ |
||||||
|
] |
||||||
|
set switches [lmap v [dict keys $opts] {list $v -}] |
||||||
|
set switches [concat {*}$switches] |
||||||
|
set switches [lrange $switches 0 end-1] |
||||||
|
foreach {k v} $args { |
||||||
|
switch -- $k\ |
||||||
|
{*}$switches { |
||||||
|
dict set opts $k $v |
||||||
|
}\ |
||||||
|
default { |
||||||
|
error "unrecognised option '$k'. Known options [dict keys $opts]" |
||||||
|
} |
||||||
|
} |
||||||
|
return $opts |
||||||
|
} |
||||||
|
proc test1_prefix {args} { |
||||||
|
set opts [dict create\ |
||||||
|
-return string\ |
||||||
|
-frametype \uFFEF\ |
||||||
|
-show_edge \uFFEF\ |
||||||
|
-show_seps \uFFEF\ |
||||||
|
-x ""\ |
||||||
|
-y b\ |
||||||
|
-z c\ |
||||||
|
-1 1\ |
||||||
|
-2 2\ |
||||||
|
-3 3\ |
||||||
|
] |
||||||
|
foreach {k v} $args { |
||||||
|
dict set opts [tcl::prefix::match -message "test1_prefix option $k" {-return -frametype -show_edge -show_seps -x -y -z -1 -2 -3} $k] $v |
||||||
|
} |
||||||
|
return $opts |
||||||
|
} |
||||||
|
proc test1_prefix2 {args} { |
||||||
|
set opts [dict create\ |
||||||
|
-return string\ |
||||||
|
-frametype \uFFEF\ |
||||||
|
-show_edge \uFFEF\ |
||||||
|
-show_seps \uFFEF\ |
||||||
|
-x ""\ |
||||||
|
-y b\ |
||||||
|
-z c\ |
||||||
|
-1 1\ |
||||||
|
-2 2\ |
||||||
|
-3 3\ |
||||||
|
] |
||||||
|
if {[llength $args]} { |
||||||
|
set knownflags [dict keys $opts] |
||||||
|
} |
||||||
|
foreach {k v} $args { |
||||||
|
dict set opts [tcl::prefix::match -message "test1_prefix2 option $k" $knownflags $k] $v |
||||||
|
} |
||||||
|
return $opts |
||||||
|
} |
||||||
|
|
||||||
|
#punk::args is slower than argp - but comparable, and argp doesn't support solo flags |
||||||
|
proc test1_punkargs {args} { |
||||||
|
set argd [punk::args::parse $args withdef { |
||||||
|
@id -id ::argparsingtest::test1_punkargs |
||||||
|
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" |
||||||
|
@opts -anyopts 0 |
||||||
|
-return -default string -type string |
||||||
|
-frametype -default \uFFEF -type string |
||||||
|
-show_edge -default \uFFEF -type string |
||||||
|
-show_seps -default \uFFEF -type string |
||||||
|
-join -type none -multiple 1 |
||||||
|
-x -default "" -type string |
||||||
|
-y -default b -type string |
||||||
|
-z -default c -type string |
||||||
|
-1 -default 1 -type boolean |
||||||
|
-2 -default 2 -type integer |
||||||
|
-3 -default 3 -type integer |
||||||
|
@values |
||||||
|
}] |
||||||
|
return [tcl::dict::get $argd opts] |
||||||
|
} |
||||||
|
|
||||||
|
punk::args::define { |
||||||
|
@id -id ::test1_punkargs_by_id |
||||||
|
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" |
||||||
|
@opts -anyopts 0 |
||||||
|
-return -default string -type string |
||||||
|
-frametype -default \uFFEF -type string |
||||||
|
-show_edge -default \uFFEF -type string |
||||||
|
-show_seps -default \uFFEF -type string |
||||||
|
-join -type none -multiple 1 |
||||||
|
-x -default "" -type string |
||||||
|
-y -default b -type string |
||||||
|
-z -default c -type string |
||||||
|
-1 -default 1 -type boolean |
||||||
|
-2 -default 2 -type integer |
||||||
|
-3 -default 3 -type integer |
||||||
|
@values |
||||||
|
} |
||||||
|
proc test1_punkargs_by_id {args} { |
||||||
|
set argd [punk::args::get_by_id ::test1_punkargs_by_id $args] |
||||||
|
return [tcl::dict::get $argd opts] |
||||||
|
} |
||||||
|
|
||||||
|
punk::args::define { |
||||||
|
@id -id ::argparsingtest::test1_punkargs2 |
||||||
|
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" |
||||||
|
@opts -anyopts 0 |
||||||
|
-return -default string -type string |
||||||
|
-frametype -default \uFFEF -type string |
||||||
|
-show_edge -default \uFFEF -type string |
||||||
|
-show_seps -default \uFFEF -type string |
||||||
|
-join -type none -multiple 1 |
||||||
|
-x -default "" -type string |
||||||
|
-y -default b -type string |
||||||
|
-z -default c -type string |
||||||
|
-1 -default 1 -type boolean |
||||||
|
-2 -default 2 -type integer |
||||||
|
-3 -default 3 -type integer |
||||||
|
@values |
||||||
|
} |
||||||
|
proc test1_punkargs2 {args} { |
||||||
|
set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args] |
||||||
|
return [tcl::dict::get $argd opts] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc test1_punkargs_validate_ansistripped {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
@id -id ::argparsingtest::test1_punkargs_validate_ansistripped |
||||||
|
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" |
||||||
|
@opts -anyopts 0 |
||||||
|
-return -default string -type string -choices {string object} -help "return type" |
||||||
|
-frametype -default \uFFEF -type string |
||||||
|
-show_edge -default \uFFEF -type string |
||||||
|
-show_seps -default \uFFEF -type string |
||||||
|
-join -type none -multiple 1 |
||||||
|
-x -default "" -type string |
||||||
|
-y -default b -type string |
||||||
|
-z -default c -type string |
||||||
|
-1 -default 1 -type boolean -validate_ansistripped true |
||||||
|
-2 -default 2 -type integer -validate_ansistripped true |
||||||
|
-3 -default 3 -type integer -validate_ansistripped true |
||||||
|
@values |
||||||
|
} $args] |
||||||
|
return [tcl::dict::get $argd opts] |
||||||
|
} |
||||||
|
|
||||||
|
package require opt |
||||||
|
variable optlist |
||||||
|
tcl::OptProc test1_opt { |
||||||
|
{-return string "return type"} |
||||||
|
{-frametype \uFFEF "type of frame"} |
||||||
|
{-show_edge \uFFEF "show table outer borders"} |
||||||
|
{-show_seps \uFFEF "show separators"} |
||||||
|
{-join "solo option"} |
||||||
|
{-x "" "x val"} |
||||||
|
{-y b "y val"} |
||||||
|
{-z c "z val"} |
||||||
|
{-1 1 "1val"} |
||||||
|
{-2 -int 2 "2val"} |
||||||
|
{-3 -int 3 "3val"} |
||||||
|
} { |
||||||
|
set opts [dict create] |
||||||
|
foreach v [info locals] { |
||||||
|
dict set opts $v [set $v] |
||||||
|
} |
||||||
|
return $opts |
||||||
|
} |
||||||
|
|
||||||
|
package require cmdline |
||||||
|
#cmdline::getoptions is much faster than typedGetoptions |
||||||
|
proc test1_cmdline_untyped {args} { |
||||||
|
set cmdlineopts_untyped { |
||||||
|
{return.arg "string" "return val"} |
||||||
|
{frametype.arg \uFFEF "frame type"} |
||||||
|
{show_edge.arg \uFFEF "show table borders"} |
||||||
|
{show_seps.arg \uFFEF "show table seps"} |
||||||
|
{join "join the things"} |
||||||
|
{x.arg "" "arg x"} |
||||||
|
{y.arg b "arg y"} |
||||||
|
{z.arg c "arg z"} |
||||||
|
{1.arg 1 "arg 1"} |
||||||
|
{2.arg 2 "arg 2"} |
||||||
|
{3.arg 3 "arg 3"} |
||||||
|
} |
||||||
|
|
||||||
|
set usage "usage etc" |
||||||
|
return [::cmdline::getoptions args $cmdlineopts_untyped $usage] |
||||||
|
} |
||||||
|
proc test1_cmdline_typed {args} { |
||||||
|
set cmdlineopts_typed { |
||||||
|
{return.arg "string" "return val"} |
||||||
|
{frametype.arg \uFFEF "frame type"} |
||||||
|
{show_edge.arg \uFFEF "show table borders"} |
||||||
|
{show_seps.arg \uFFEF "show table seps"} |
||||||
|
{join "join the things"} |
||||||
|
{x.arg "" "arg x"} |
||||||
|
{y.arg b "arg y"} |
||||||
|
{z.arg c "arg z"} |
||||||
|
{1.boolean 1 "arg 1"} |
||||||
|
{2.integer 2 "arg 2"} |
||||||
|
{3.integer 3 "arg 3"} |
||||||
|
} |
||||||
|
|
||||||
|
set usage "usage etc" |
||||||
|
return [::cmdline::typedGetoptions args $cmdlineopts_typed $usage] |
||||||
|
} |
||||||
|
|
||||||
|
catch { |
||||||
|
package require argp |
||||||
|
argp::registerArgs test1_argp { |
||||||
|
{ -return string "string" } |
||||||
|
{ -frametype string \uFFEF } |
||||||
|
{ -show_edge string \uFFEF } |
||||||
|
{ -show_seps string \uFFEF } |
||||||
|
{ -x string "" } |
||||||
|
{ -y string b } |
||||||
|
{ -z string c } |
||||||
|
{ -1 boolean 1 } |
||||||
|
{ -2 integer 2 } |
||||||
|
{ -3 integer 3 } |
||||||
|
} |
||||||
|
} |
||||||
|
proc test1_argp {args} { |
||||||
|
argp::parseArgs opts |
||||||
|
return [array get opts] |
||||||
|
} |
||||||
|
|
||||||
|
package require tepam |
||||||
|
tepam::procedure {test1_tepam} { |
||||||
|
-args { |
||||||
|
{-return -type string -default string} |
||||||
|
{-frametype -type string -default \uFFEF} |
||||||
|
{-show_edge -type string -default \uFFEF} |
||||||
|
{-show_seps -type string -default \uFFEF} |
||||||
|
{-join -type none -multiple} |
||||||
|
{-x -type string -default ""} |
||||||
|
{-y -type string -default b} |
||||||
|
{-z -type string -default c} |
||||||
|
{-1 -type boolean -default 1} |
||||||
|
{-2 -type integer -default 2} |
||||||
|
{-3 -type integer -default 3} |
||||||
|
} |
||||||
|
} { |
||||||
|
return [dict create return $return frametype $frametype show_edge $show_edge show_seps $show_seps x $x y $y z $z 1 $1 2 $2 3 $3 join $join] |
||||||
|
} |
||||||
|
|
||||||
|
#multiline values use first line of each record to determine amount of indent to trim |
||||||
|
proc test_multiline {args} { |
||||||
|
set t3 [textblock::frame t3] |
||||||
|
set argd [punk::args::get_dict [subst { |
||||||
|
-template1 -default { |
||||||
|
****** |
||||||
|
* t1 * |
||||||
|
****** |
||||||
|
} |
||||||
|
-template2 -default { ------ |
||||||
|
****** |
||||||
|
* t2 * |
||||||
|
******} |
||||||
|
-template3 -default {$t3} |
||||||
|
#substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately |
||||||
|
-template3b -default { |
||||||
|
$t3 |
||||||
|
----------------- |
||||||
|
$t3 |
||||||
|
abc\ndef |
||||||
|
} |
||||||
|
-template4 -default "****** |
||||||
|
* t4 * |
||||||
|
******" |
||||||
|
-template5 -default " |
||||||
|
|
||||||
|
|
||||||
|
" |
||||||
|
-flag -default 0 -type boolean |
||||||
|
}] $args] |
||||||
|
return $argd |
||||||
|
} |
||||||
|
|
||||||
|
#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 argparsingtest ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval argparsingtest::lib { |
||||||
|
namespace export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace argparsingtest::lib}] |
||||||
|
#[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 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace argparsingtest::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval argparsingtest::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace argparsingtest::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide argparsingtest [namespace eval argparsingtest { |
||||||
|
variable pkg argparsingtest |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,514 @@ |
|||||||
|
|
||||||
|
|
||||||
|
#JMN 2021 - Public Domain |
||||||
|
#cooperative command renaming |
||||||
|
# |
||||||
|
# REVIEW 2024 - code was originally for specific use in packageTrace |
||||||
|
# - code should be reviewed for more generic utility. |
||||||
|
# - API is obscure and undocumented. |
||||||
|
# - unclear if intention was only for builtins |
||||||
|
# - consider use of newer 'info cmdtype' - (but need also support for safe interps) |
||||||
|
# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. |
||||||
|
# - document that replacement command should use 'commandstack::get_next_command <cmd> <renamer>' for delegating to command as it was prior to rename |
||||||
|
#changes: |
||||||
|
#2024 |
||||||
|
# - mungecommand to support namespaced commands |
||||||
|
# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_<mungedcommand> |
||||||
|
#2021-09-18 |
||||||
|
# - initial version |
||||||
|
# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command |
||||||
|
# - They need to be able to load and unload in any order. |
||||||
|
# |
||||||
|
|
||||||
|
#strive for no other package dependencies here. |
||||||
|
|
||||||
|
|
||||||
|
namespace eval commandstack { |
||||||
|
variable all_stacks |
||||||
|
variable debug |
||||||
|
set debug 0 |
||||||
|
variable known_renamers [list ::packagetrace ::packageSuppress] |
||||||
|
if {![info exists all_stacks]} { |
||||||
|
#don't wipe it |
||||||
|
set all_stacks [dict create] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
namespace eval commandstack::util { |
||||||
|
#note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. |
||||||
|
#We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace |
||||||
|
#A magic comment was chosen as the identifying method. |
||||||
|
#The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. |
||||||
|
|
||||||
|
#return unspecified if the command is a proc with a body but no magic comment ID |
||||||
|
#return unknown if the command doesn't have a proc body to analyze |
||||||
|
#otherwise return the package name identified in the magic comment |
||||||
|
proc get_IMPLEMENTOR {command} { |
||||||
|
#assert - command has already been resolved to a namespace ie fully qualified |
||||||
|
if {[llength [info procs $command]]} { |
||||||
|
#look for *IMPLEMENTOR_*! |
||||||
|
set prefix IMPLEMENTOR_ |
||||||
|
set suffix "!" |
||||||
|
set body [uplevel 1 [list info body $command]] |
||||||
|
if {[string match "*$prefix*$suffix*" $body]} { |
||||||
|
set prefixposn [string first "$prefix" $body] |
||||||
|
set pkgposn [expr {$prefixposn + [string length $prefix]}] |
||||||
|
#set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] |
||||||
|
set suffixposn [string first $suffix $body $pkgposn] |
||||||
|
return [string range $body $pkgposn $suffixposn-1] |
||||||
|
} else { |
||||||
|
return unspecified |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {[info commands tcl::info::cmdtype] ne ""} { |
||||||
|
#tcl9 and maybe some tcl 8.7s ? |
||||||
|
switch -- [tcl::info::cmdtype $command] { |
||||||
|
native { |
||||||
|
return builtin |
||||||
|
} |
||||||
|
default { |
||||||
|
return undetermined |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
return undetermined |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
namespace eval commandstack::renamed_commands {} |
||||||
|
namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place |
||||||
|
|
||||||
|
namespace eval commandstack { |
||||||
|
namespace export {[a-z]*} |
||||||
|
proc help {} { |
||||||
|
return { |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc debug {{on_off {}}} { |
||||||
|
variable debug |
||||||
|
if {$on_off eq ""} { |
||||||
|
return $debug |
||||||
|
} else { |
||||||
|
if {[string is boolean -strict $debug]} { |
||||||
|
set debug [expr {$on_off && 1}] |
||||||
|
return $debug |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc get_stack {command} { |
||||||
|
variable all_stacks |
||||||
|
set command [uplevel 1 [list namespace which $command]] |
||||||
|
if {[dict exists $all_stacks $command]} { |
||||||
|
return [dict get $all_stacks $command] |
||||||
|
} else { |
||||||
|
return [list] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. |
||||||
|
#review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? |
||||||
|
#e.g if renaming builtin 'package' - this command is generally called 'a lot' |
||||||
|
proc get_next_command {command renamer tokenid} { |
||||||
|
variable all_stacks |
||||||
|
if {[dict exists $all_stacks $command]} { |
||||||
|
set stack [dict get $all_stacks $command] |
||||||
|
set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] |
||||||
|
if {$posn > -1} { |
||||||
|
set record [lindex $stack $posn] |
||||||
|
return [dict get $record implementation] |
||||||
|
} else { |
||||||
|
error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" |
||||||
|
} |
||||||
|
} else { |
||||||
|
return $command |
||||||
|
} |
||||||
|
} |
||||||
|
proc basecall {command args} { |
||||||
|
variable all_stacks |
||||||
|
set command [uplevel 1 [list namespace which $command]] |
||||||
|
if {[dict exists $all_stacks $command]} { |
||||||
|
set stack [dict get $all_stacks $command] |
||||||
|
if {[llength $stack]} { |
||||||
|
set rec1 [lindex $stack 0] |
||||||
|
tailcall [dict get $rec1 implementation] {*}$args |
||||||
|
} else { |
||||||
|
tailcall $command {*}$args |
||||||
|
} |
||||||
|
} else { |
||||||
|
tailcall $command {*}$args |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#review. |
||||||
|
#<renamer> defaults to calling namespace - but can be arbitrary string |
||||||
|
proc rename_command {args} { |
||||||
|
#todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames |
||||||
|
# - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack |
||||||
|
# |
||||||
|
if {[lindex $args 0] eq "-renamer"} { |
||||||
|
set renamer [lindex $args 1] |
||||||
|
set arglist [lrange $args 2 end] |
||||||
|
} else { |
||||||
|
set renamer "" |
||||||
|
set arglist $args |
||||||
|
} |
||||||
|
if {[llength $arglist] != 3} { |
||||||
|
error "commandstack::rename_command usage: rename_command ?-renamer <string>? command procargs procbody" |
||||||
|
} |
||||||
|
lassign $arglist command procargs procbody |
||||||
|
|
||||||
|
set command [uplevel 1 [list namespace which $command]] |
||||||
|
set mungedcommand [string map {:: _ns_} $command] |
||||||
|
set mungedrenamer [string map {:: _ns_} $renamer] |
||||||
|
variable all_stacks |
||||||
|
variable known_renamers |
||||||
|
variable renamer_command_tokens ;#monotonically increasing int per <mungedrenamer>::<mungedcommand> representing number of renames ever done. |
||||||
|
if {$renamer eq ""} { |
||||||
|
set renamer [uplevel 1 [list namespace current]] |
||||||
|
} |
||||||
|
if {$renamer ni $known_renamers} { |
||||||
|
lappend known_renamers $renamer |
||||||
|
dict set renamer_command_tokens [list $renamer $command] 0 |
||||||
|
} |
||||||
|
|
||||||
|
#TODO - reduce emissions to stderr - flag for debug? |
||||||
|
|
||||||
|
#e.g packageTrace and packageSuppress packages use this convention. |
||||||
|
set nextinfo [uplevel 1 [list\ |
||||||
|
apply {{command renamer procbody} { |
||||||
|
#todo - munge dash so we can make names in renamed_commands separable |
||||||
|
# {- _dash_} ? |
||||||
|
set mungedcommand [string map {:: _ns_} $command] |
||||||
|
set mungedrenamer [string map {:: _ns_} $renamer] |
||||||
|
set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] |
||||||
|
set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. |
||||||
|
set do_rename 0 |
||||||
|
if {[llength [info procs $command]] || [llength [info commands $next_target]]} { |
||||||
|
#$command is not the standard builtin - something has replaced it, could be ourself. |
||||||
|
set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] |
||||||
|
set munged_next_implementor [string map {:: _ns_} $next_implementor] |
||||||
|
#if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. |
||||||
|
if {[dict exists $::commandstack::all_stacks $command]} { |
||||||
|
set comstacks [dict get $::commandstack::all_stacks $command] |
||||||
|
} else { |
||||||
|
set comstacks [list] |
||||||
|
} |
||||||
|
set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') |
||||||
|
if {[llength $this_renamer_previous_entries]} { |
||||||
|
if {$next_implementor eq $renamer} { |
||||||
|
#previous renamer was us. Rather than assume our job is done.. compare the implementations |
||||||
|
#don't rename if immediate predecessor is same code. |
||||||
|
#set topstack [lindex $comstacks end] |
||||||
|
#set next_impl [dict get $topstack implementation] |
||||||
|
set current_body [info body $command] |
||||||
|
lassign [commandstack::lib::split_body $current_body] _ current_code |
||||||
|
set current_code [string trim $current_code] |
||||||
|
set new_code [string trim $procbody] |
||||||
|
if {$current_code eq $new_code} { |
||||||
|
puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." |
||||||
|
puts stderr [::commandstack::show_stack $command] |
||||||
|
} else { |
||||||
|
puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." |
||||||
|
puts stdout "----------" |
||||||
|
puts stdout "$current_code" |
||||||
|
puts stdout "----------" |
||||||
|
puts stdout "$new_code" |
||||||
|
puts stdout "----------" |
||||||
|
set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid |
||||||
|
set do_rename 1 |
||||||
|
} |
||||||
|
} else { |
||||||
|
puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" |
||||||
|
puts stderr |
||||||
|
set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid |
||||||
|
set do_rename 1 |
||||||
|
} |
||||||
|
} elseif {$next_implementor in $::commandstack::known_renamers} { |
||||||
|
set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid |
||||||
|
set do_rename 1 |
||||||
|
} elseif {$next_implementor in {builtin}} { |
||||||
|
#native/builtin could still have been renamed |
||||||
|
set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid |
||||||
|
set do_rename 1 |
||||||
|
} elseif {$next_implementor in {unspecified undetermined}} { |
||||||
|
#could be a standard tcl proc, or from application or package |
||||||
|
set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid |
||||||
|
set do_rename 1 |
||||||
|
} else { |
||||||
|
puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" |
||||||
|
set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid |
||||||
|
set do_rename 1 |
||||||
|
} |
||||||
|
} else { |
||||||
|
#_originalcommand_<mungedcommand> |
||||||
|
#assume builtin/original |
||||||
|
set next_implementor original |
||||||
|
#rename $command $next_target |
||||||
|
set do_rename 1 |
||||||
|
} |
||||||
|
#There are of course other ways in which $command may have been renamed - but we can't detect. |
||||||
|
set token [list $command $renamer $tokenid] |
||||||
|
return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] |
||||||
|
} } $command $renamer $procbody] |
||||||
|
] |
||||||
|
|
||||||
|
|
||||||
|
variable debug |
||||||
|
if {$debug} { |
||||||
|
if {[dict exists $all_stacks $command]} { |
||||||
|
set stack [dict get $all_stacks $command] |
||||||
|
puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" |
||||||
|
} else { |
||||||
|
#assume this is the original |
||||||
|
puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) |
||||||
|
#renamer is always second dict entry (Value needs to be searched with lsearch -index 3) |
||||||
|
set new_record [dict create\ |
||||||
|
token [dict get $nextinfo token]\ |
||||||
|
renamer $renamer\ |
||||||
|
next_implementor [dict get $nextinfo next_implementor]\ |
||||||
|
next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ |
||||||
|
implementation [dict get $nextinfo next_target]\ |
||||||
|
] |
||||||
|
if {![dict get $nextinfo do_rename]} { |
||||||
|
#review |
||||||
|
puts stderr "no rename performed" |
||||||
|
return [dict create implementation ""] |
||||||
|
} |
||||||
|
catch {rename ::commandstack::temp::testproc ""} |
||||||
|
set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { |
||||||
|
#IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% <procargs> <procbody> ) |
||||||
|
set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. |
||||||
|
set COMMANDSTACKNEXT [%next_getter%] |
||||||
|
#<commandstack_separator># |
||||||
|
}] |
||||||
|
set final_procbody "$nextinit$procbody" |
||||||
|
#build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command |
||||||
|
#(e.g due to invalid argument specifiers) |
||||||
|
proc ::commandstack::temp::testproc $procargs $final_procbody |
||||||
|
uplevel 1 [list rename $command [dict get $nextinfo next_target]] |
||||||
|
uplevel 1 [list rename ::commandstack::temp::testproc $command] |
||||||
|
dict lappend all_stacks $command $new_record |
||||||
|
|
||||||
|
|
||||||
|
return $new_record |
||||||
|
} |
||||||
|
|
||||||
|
#todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer |
||||||
|
#todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost |
||||||
|
#todo - removal of all entries pertaining to a particular renamer |
||||||
|
#todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? |
||||||
|
|
||||||
|
#remove by token, or by commandname if called from same context as original rename_command |
||||||
|
#If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. |
||||||
|
#A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. |
||||||
|
#similarly a nonexistant token or renamer will not remove anything and will just return the current stack |
||||||
|
proc remove_rename {token_or_command} { |
||||||
|
if {[llength $token_or_command] == 3} { |
||||||
|
#is token |
||||||
|
lassign $token_or_command command renamer tokenid |
||||||
|
} elseif {[llength $token_or_command] == 2} { |
||||||
|
#command and renamer only supplied |
||||||
|
lassign $token_or_command command renamer |
||||||
|
set tokenid "" |
||||||
|
} elseif {[llength $token_or_command] == 1} { |
||||||
|
#is command name only |
||||||
|
set command $token_or_command |
||||||
|
set renamer [uplevel 1 [list namespace current]] |
||||||
|
set tokenid "" |
||||||
|
} |
||||||
|
set command [uplevel 1 [list namespace which $command]] |
||||||
|
variable all_stacks |
||||||
|
variable known_renamers |
||||||
|
if {$renamer ni $known_renamers} { |
||||||
|
error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or {<command> <renamer>}" |
||||||
|
} |
||||||
|
if {[dict exists $all_stacks $command]} { |
||||||
|
set stack [dict get $all_stacks $command] |
||||||
|
if {$tokenid ne ""} { |
||||||
|
#token_or_command is a token as returned within the rename_command result dictionary |
||||||
|
#search first dict value |
||||||
|
set doomed_posn [lsearch -index 1 $stack $token_or_command] |
||||||
|
} else { |
||||||
|
#search second dict value |
||||||
|
set matches [lsearch -all -index 3 $stack $renamer] |
||||||
|
set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer |
||||||
|
} |
||||||
|
if {$doomed_posn ne "" && $doomed_posn > -1} { |
||||||
|
set doomed_record [lindex $stack $doomed_posn] |
||||||
|
if {[llength $stack] == ($doomed_posn + 1)} { |
||||||
|
#last on stack - put the implemenation from the doomed_record back as the actual command |
||||||
|
uplevel #0 [list rename $command ""] |
||||||
|
uplevel #0 [list rename [dict get $doomed_record implementation] $command] |
||||||
|
} elseif {[llength $stack] > ($doomed_posn + 1)} { |
||||||
|
#there is at least one more record on the stack - rewrite it to point where the doomed_record pointed |
||||||
|
set rewrite_posn [expr {$doomed_posn + 1}] |
||||||
|
set rewrite_record [lindex $stack $rewrite_posn] |
||||||
|
|
||||||
|
if {[dict get $rewrite_record next_implementor] ne $renamer} { |
||||||
|
puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" |
||||||
|
} else { |
||||||
|
uplevel #0 [list rename [dict get $rewrite_record implementation] ""] |
||||||
|
} |
||||||
|
dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] |
||||||
|
#don't update next_getter - it always refers to self |
||||||
|
dict set rewrite_record implementation [dict get $doomed_record implementation] |
||||||
|
lset stack $rewrite_posn $rewrite_record |
||||||
|
dict set all_stacks $command $stack |
||||||
|
} |
||||||
|
set stack [lreplace $stack $doomed_posn $doomed_posn] |
||||||
|
dict set all_stacks $command $stack |
||||||
|
|
||||||
|
} |
||||||
|
return $stack |
||||||
|
} |
||||||
|
return [list] |
||||||
|
} |
||||||
|
|
||||||
|
proc show_stack {{commandname_glob *}} { |
||||||
|
variable all_stacks |
||||||
|
if {![regexp {[?*]} $commandname_glob]} { |
||||||
|
#if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace |
||||||
|
set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] |
||||||
|
} |
||||||
|
if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { |
||||||
|
#punk pipeline also needed for patterns |
||||||
|
return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] |
||||||
|
} else { |
||||||
|
set result "" |
||||||
|
set matchedkeys [dict keys $all_stacks $commandname_glob] |
||||||
|
#don't try to calculate widest on empty list |
||||||
|
if {[llength $matchedkeys]} { |
||||||
|
set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] |
||||||
|
set indent [string repeat " " [expr {$widest + 3}]] |
||||||
|
set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide |
||||||
|
set padkey [string repeat " " 20] |
||||||
|
foreach k $matchedkeys { |
||||||
|
append result "$k = " |
||||||
|
set i 0 |
||||||
|
foreach stackmember [dict get $all_stacks $k] { |
||||||
|
if {$i > 0} { |
||||||
|
append result "\n$indent" |
||||||
|
} |
||||||
|
append result [string range "$i " 0 4] " = " |
||||||
|
set j 0 |
||||||
|
dict for {k v} $stackmember { |
||||||
|
if {$j > 0} { |
||||||
|
append result "\n$indent2" |
||||||
|
} |
||||||
|
set displaykey [string range "$k$padkey" 0 20] |
||||||
|
append result "$displaykey = $v" |
||||||
|
incr j |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
append result \n |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#review |
||||||
|
#document when this is to be called. Wiping stacks without undoing renames seems odd. |
||||||
|
proc Delete_stack {command} { |
||||||
|
variable all_stacks |
||||||
|
if {[dict exists $all_stacks $command]} { |
||||||
|
dict unset all_stacks $command |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
return 1 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#can be used to temporarily put a stack aside - should manually rename back when done. |
||||||
|
#review - document how/when to use. example? intention? |
||||||
|
proc Rename_stack {oldname newname} { |
||||||
|
variable all_stacks |
||||||
|
if {[dict exists $all_stacks $oldname]} { |
||||||
|
if {[dict exists $all_stacks $newname]} { |
||||||
|
error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" |
||||||
|
} else { |
||||||
|
#set stackval [dict get $all_stacks $oldname] |
||||||
|
#dict unset all_stacks $oldname |
||||||
|
#dict set all_stacks $newname $stackval |
||||||
|
dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
namespace eval commandstack::lib { |
||||||
|
proc splitx {str {regexp {[\t \r\n]+}}} { |
||||||
|
#snarfed from tcllib textutil::splitx to avoid the dependency |
||||||
|
# Bugfix 476988 |
||||||
|
if {[string length $str] == 0} { |
||||||
|
return {} |
||||||
|
} |
||||||
|
if {[string length $regexp] == 0} { |
||||||
|
return [::split $str ""] |
||||||
|
} |
||||||
|
if {[regexp $regexp {}]} { |
||||||
|
return -code error "splitting on regexp \"$regexp\" would cause infinite loop" |
||||||
|
} |
||||||
|
|
||||||
|
set list {} |
||||||
|
set start 0 |
||||||
|
while {[regexp -start $start -indices -- $regexp $str match submatch]} { |
||||||
|
foreach {subStart subEnd} $submatch break |
||||||
|
foreach {matchStart matchEnd} $match break |
||||||
|
incr matchStart -1 |
||||||
|
incr matchEnd |
||||||
|
lappend list [string range $str $start $matchStart] |
||||||
|
if {$subStart >= $start} { |
||||||
|
lappend list [string range $str $subStart $subEnd] |
||||||
|
} |
||||||
|
set start $matchEnd |
||||||
|
} |
||||||
|
lappend list [string range $str $start end] |
||||||
|
return $list |
||||||
|
} |
||||||
|
proc split_body {procbody} { |
||||||
|
set marker "#<commandstack_separator>#" |
||||||
|
set header "" |
||||||
|
set code "" |
||||||
|
set found_marker 0 |
||||||
|
foreach ln [split $procbody \n] { |
||||||
|
if {!$found_marker} { |
||||||
|
if {[string trim $ln] eq $marker} { |
||||||
|
set found_marker 1 |
||||||
|
} else { |
||||||
|
append header $ln \n |
||||||
|
} |
||||||
|
} else { |
||||||
|
append code $ln \n |
||||||
|
} |
||||||
|
} |
||||||
|
if {$found_marker} { |
||||||
|
return [list $header $code] |
||||||
|
} else { |
||||||
|
return [list "" $procbody] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
package provide commandstack [namespace eval commandstack { |
||||||
|
set version 0.3 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
@ -0,0 +1,306 @@ |
|||||||
|
# Debug - a debug narrative logger. |
||||||
|
# -- Colin McCormack / originally Wub server utilities |
||||||
|
# |
||||||
|
# Debugging areas of interest are represented by 'tokens' which have |
||||||
|
# independantly settable levels of interest (an integer, higher is more detailed) |
||||||
|
# |
||||||
|
# Debug narrative is provided as a tcl script whose value is [subst]ed in the |
||||||
|
# caller's scope if and only if the current level of interest matches or exceeds |
||||||
|
# the Debug call's level of detail. This is useful, as one can place arbitrarily |
||||||
|
# complex narrative in code without unnecessarily evaluating it. |
||||||
|
# |
||||||
|
# TODO: potentially different streams for different areas of interest. |
||||||
|
# (currently only stderr is used. there is some complexity in efficient |
||||||
|
# cross-threaded streams.) |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Requisites |
||||||
|
|
||||||
|
package require Tcl 8.5- |
||||||
|
|
||||||
|
namespace eval ::debug { |
||||||
|
namespace export -clear \ |
||||||
|
define on off prefix suffix header trailer \ |
||||||
|
names 2array level setting parray pdict \ |
||||||
|
nl tab hexl |
||||||
|
namespace ensemble create -subcommands {} |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## API & Implementation |
||||||
|
|
||||||
|
proc ::debug::noop {args} {} |
||||||
|
|
||||||
|
proc ::debug::debug {tag message {level 1}} { |
||||||
|
variable detail |
||||||
|
if {$detail($tag) < $level} { |
||||||
|
#puts stderr "$tag @@@ $detail($tag) >= $level" |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
variable prefix |
||||||
|
variable suffix |
||||||
|
variable header |
||||||
|
variable trailer |
||||||
|
variable fds |
||||||
|
|
||||||
|
if {[info exists fds($tag)]} { |
||||||
|
set fd $fds($tag) |
||||||
|
} else { |
||||||
|
set fd stderr |
||||||
|
} |
||||||
|
|
||||||
|
# Assemble the shown text from the user message and the various |
||||||
|
# prefixes and suffices (global + per-tag). |
||||||
|
|
||||||
|
set themessage "" |
||||||
|
if {[info exists prefix(::)]} { append themessage $prefix(::) } |
||||||
|
if {[info exists prefix($tag)]} { append themessage $prefix($tag) } |
||||||
|
append themessage $message |
||||||
|
if {[info exists suffix($tag)]} { append themessage $suffix($tag) } |
||||||
|
if {[info exists suffix(::)]} { append themessage $suffix(::) } |
||||||
|
|
||||||
|
# Resolve variables references and command invokations embedded |
||||||
|
# into the message with plain text. |
||||||
|
set code [catch { |
||||||
|
set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]] |
||||||
|
set sheader [uplevel 1 [list ::subst -nobackslashes $header]] |
||||||
|
set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]] |
||||||
|
} __ eo] |
||||||
|
|
||||||
|
# And dump an internal error if that resolution failed. |
||||||
|
if {$code} { |
||||||
|
if {[catch { |
||||||
|
set caller [info level -1] |
||||||
|
}]} { set caller GLOBAL } |
||||||
|
if {[string length $caller] >= 1000} { |
||||||
|
set caller "[string range $caller 0 200]...[string range $caller end-200 end]" |
||||||
|
} |
||||||
|
foreach line [split $caller \n] { |
||||||
|
puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)" |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# From here we have a good message to show. We only shorten it a |
||||||
|
# bit if its a bit excessive in size. |
||||||
|
|
||||||
|
if {[string length $smessage] > 4096} { |
||||||
|
set head [string range $smessage 0 2048] |
||||||
|
set tail [string range $smessage end-2048 end] |
||||||
|
set smessage "${head}...(truncated)...$tail" |
||||||
|
} |
||||||
|
|
||||||
|
foreach line [split $smessage \n] { |
||||||
|
puts $fd "$sheader$tag | $line$strailer" |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# names - return names of debug tags |
||||||
|
proc ::debug::names {} { |
||||||
|
variable detail |
||||||
|
return [lsort [array names detail]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::2array {} { |
||||||
|
variable detail |
||||||
|
set result {} |
||||||
|
foreach n [lsort [array names detail]] { |
||||||
|
if {[interp alias {} debug.$n] ne "::debug::noop"} { |
||||||
|
lappend result $n $detail($n) |
||||||
|
} else { |
||||||
|
lappend result $n -$detail($n) |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# level - set level and fd for tag |
||||||
|
proc ::debug::level {tag {level ""} {fd {}}} { |
||||||
|
variable detail |
||||||
|
# TODO: Force level >=0. |
||||||
|
if {$level ne ""} { |
||||||
|
set detail($tag) $level |
||||||
|
} |
||||||
|
|
||||||
|
if {![info exists detail($tag)]} { |
||||||
|
set detail($tag) 1 |
||||||
|
} |
||||||
|
|
||||||
|
variable fds |
||||||
|
if {$fd ne {}} { |
||||||
|
set fds($tag) $fd |
||||||
|
} |
||||||
|
|
||||||
|
return $detail($tag) |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::header {text} { variable header $text } |
||||||
|
proc ::debug::trailer {text} { variable trailer $text } |
||||||
|
|
||||||
|
proc ::debug::define {tag} { |
||||||
|
if {[interp alias {} debug.$tag] ne {}} return |
||||||
|
off $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# Set a prefix/suffix to use for tag. |
||||||
|
# The global (tag-independent) prefix/suffix is adressed through tag '::'. |
||||||
|
# This works because colon (:) is an illegal character for user-specified tags. |
||||||
|
|
||||||
|
proc ::debug::prefix {tag {theprefix {}}} { |
||||||
|
variable prefix |
||||||
|
set prefix($tag) $theprefix |
||||||
|
|
||||||
|
if {[interp alias {} debug.$tag] ne {}} return |
||||||
|
off $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::suffix {tag {theprefix {}}} { |
||||||
|
variable suffix |
||||||
|
set suffix($tag) $theprefix |
||||||
|
|
||||||
|
if {[interp alias {} debug.$tag] ne {}} return |
||||||
|
off $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# turn on debugging for tag |
||||||
|
proc ::debug::on {tag {level ""} {fd {}}} { |
||||||
|
variable active |
||||||
|
set active($tag) 1 |
||||||
|
level $tag $level $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::debug $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# turn off debugging for tag |
||||||
|
proc ::debug::off {tag {level ""} {fd {}}} { |
||||||
|
variable active |
||||||
|
set active($tag) 1 |
||||||
|
level $tag $level $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::noop |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::setting {args} { |
||||||
|
if {[llength $args] == 1} { |
||||||
|
set args [lindex $args 0] |
||||||
|
} |
||||||
|
set fd stderr |
||||||
|
if {[llength $args] % 2} { |
||||||
|
set fd [lindex $args end] |
||||||
|
set args [lrange $args 0 end-1] |
||||||
|
} |
||||||
|
foreach {tag level} $args { |
||||||
|
if {$level > 0} { |
||||||
|
level $tag $level $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::debug $tag |
||||||
|
} else { |
||||||
|
level $tag [expr {-$level}] $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::noop |
||||||
|
} |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Convenience commands. |
||||||
|
# Format arrays and dicts as multi-line message. |
||||||
|
# Insert newlines and tabs. |
||||||
|
|
||||||
|
proc ::debug::nl {} { return \n } |
||||||
|
proc ::debug::tab {} { return \t } |
||||||
|
|
||||||
|
proc ::debug::parray {a {pattern *}} { |
||||||
|
upvar 1 $a array |
||||||
|
if {![array exists array]} { |
||||||
|
error "\"$a\" isn't an array" |
||||||
|
} |
||||||
|
pdict [array get array] $pattern |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::pdict {dict {pattern *}} { |
||||||
|
set maxl 0 |
||||||
|
set names [lsort -dict [dict keys $dict $pattern]] |
||||||
|
foreach name $names { |
||||||
|
if {[string length $name] > $maxl} { |
||||||
|
set maxl [string length $name] |
||||||
|
} |
||||||
|
} |
||||||
|
set maxl [expr {$maxl + 2}] |
||||||
|
set lines {} |
||||||
|
foreach name $names { |
||||||
|
set nameString [format (%s) $name] |
||||||
|
lappend lines [format "%-*s = %s" \ |
||||||
|
$maxl $nameString \ |
||||||
|
[dict get $dict $name]] |
||||||
|
} |
||||||
|
return [join $lines \n] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::hexl {data {prefix {}}} { |
||||||
|
set r {} |
||||||
|
|
||||||
|
# Convert the data to hex and to characters. |
||||||
|
binary scan $data H*@0a* hexa asciia |
||||||
|
|
||||||
|
# Replace non-printing characters in the data with dots. |
||||||
|
regsub -all -- {[^[:graph:] ]} $asciia {.} asciia |
||||||
|
|
||||||
|
# Pad with spaces to a full multiple of 32/16. |
||||||
|
set n [expr {[string length $hexa] % 32}] |
||||||
|
if {$n < 32} { append hexa [string repeat { } [expr {32-$n}]] } |
||||||
|
#puts "pad H [expr {32-$n}]" |
||||||
|
|
||||||
|
set n [expr {[string length $asciia] % 32}] |
||||||
|
if {$n < 16} { append asciia [string repeat { } [expr {16-$n}]] } |
||||||
|
#puts "pad A [expr {32-$n}]" |
||||||
|
|
||||||
|
# Reassemble formatted, in groups of 16 bytes/characters. |
||||||
|
# The hex part is handled in groups of 32 nibbles. |
||||||
|
set addr 0 |
||||||
|
while {[string length $hexa]} { |
||||||
|
# Get front group of 16 bytes each. |
||||||
|
set hex [string range $hexa 0 31] |
||||||
|
set ascii [string range $asciia 0 15] |
||||||
|
# Prep for next iteration |
||||||
|
set hexa [string range $hexa 32 end] |
||||||
|
set asciia [string range $asciia 16 end] |
||||||
|
|
||||||
|
# Convert the hex to pairs of hex digits |
||||||
|
regsub -all -- {..} $hex {& } hex |
||||||
|
|
||||||
|
# Add the hex and latin-1 data to the result buffer |
||||||
|
append r $prefix [format %04x $addr] { | } $hex { |} $ascii |\n |
||||||
|
incr addr 16 |
||||||
|
} |
||||||
|
|
||||||
|
# And done |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
|
||||||
|
namespace eval debug { |
||||||
|
variable detail ; # map: TAG -> level of interest |
||||||
|
variable prefix ; # map: TAG -> message prefix to use |
||||||
|
variable suffix ; # map: TAG -> message suffix to use |
||||||
|
variable fds ; # map: TAG -> handle of open channel to log to. |
||||||
|
variable header {} ; # per-line heading, subst'ed |
||||||
|
variable trailer {} ; # per-line ending, subst'ed |
||||||
|
|
||||||
|
# Notes: |
||||||
|
# - The tag '::' is reserved. "prefix" and "suffix" use it to store |
||||||
|
# the global message prefix / suffix. |
||||||
|
# - prefix and suffix are applied per message. |
||||||
|
# - header and trailer are per line. And should not generate multiple lines! |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide debug 1.0.6 |
||||||
|
return |
||||||
@ -0,0 +1,74 @@ |
|||||||
|
# paths.tcl -- |
||||||
|
# |
||||||
|
# Manage lists of search paths. |
||||||
|
# |
||||||
|
# Copyright (c) 2009-2019 Andreas Kupries <andreas_kupries@sourceforge.net> |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
|
||||||
|
# Each object instance manages a list of paths. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requisites |
||||||
|
|
||||||
|
package require Tcl 8.4 |
||||||
|
package require snit |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## API |
||||||
|
|
||||||
|
snit::type ::fileutil::paths { |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Options :: None |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Creation, destruction |
||||||
|
|
||||||
|
# Default constructor. |
||||||
|
# Default destructor. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Methods :: Querying and manipulating the list of paths. |
||||||
|
|
||||||
|
method paths {} { |
||||||
|
return $mypaths |
||||||
|
} |
||||||
|
|
||||||
|
method add {path} { |
||||||
|
set pos [lsearch $mypaths $path] |
||||||
|
if {$pos >= 0 } return |
||||||
|
lappend mypaths $path |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method remove {path} { |
||||||
|
set pos [lsearch $mypaths $path] |
||||||
|
if {$pos < 0} return |
||||||
|
set mypaths [lreplace $mypaths $pos $pos] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method clear {} { |
||||||
|
set mypaths {} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Internal methods :: None |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## State :: List of paths. |
||||||
|
|
||||||
|
variable mypaths {} |
||||||
|
|
||||||
|
## |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide fileutil::paths 1 |
||||||
|
return |
||||||
@ -0,0 +1,504 @@ |
|||||||
|
# traverse.tcl -- |
||||||
|
# |
||||||
|
# Directory traversal. |
||||||
|
# |
||||||
|
# Copyright (c) 2006-2015 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
|
||||||
|
package require Tcl 8.3 |
||||||
|
|
||||||
|
# OO core |
||||||
|
if {[package vsatisfies [package present Tcl] 8.5]} { |
||||||
|
# Use new Tcl 8.5a6+ features to specify the allowed packages. |
||||||
|
# We can use anything above 1.3. This means v2 as well. |
||||||
|
package require snit 1.3- |
||||||
|
} else { |
||||||
|
# For Tcl 8.{3,4} only snit1 of a suitable patchlevel is possible. |
||||||
|
package require snit 1.3 |
||||||
|
} |
||||||
|
package require control ; # Helpers for control structures |
||||||
|
package require fileutil ; # -> fullnormalize |
||||||
|
|
||||||
|
snit::type ::fileutil::traverse { |
||||||
|
|
||||||
|
# Incremental directory traversal. |
||||||
|
|
||||||
|
# API |
||||||
|
# create %AUTO% basedirectory options... -> object |
||||||
|
# next filevar -> boolean |
||||||
|
# foreach filevar script |
||||||
|
# files -> list (path ...) |
||||||
|
|
||||||
|
# Options |
||||||
|
# -prefilter command-prefix |
||||||
|
# -filter command-prefix |
||||||
|
# -errorcmd command-prefix |
||||||
|
|
||||||
|
# Use cases |
||||||
|
# |
||||||
|
# (a) Basic incremental |
||||||
|
# - Create and configure a traversal object. |
||||||
|
# - Execute 'next' to retrieve one path at a time, |
||||||
|
# until the command returns False, signaling that |
||||||
|
# the iterator has exhausted the supply of paths. |
||||||
|
# (The path is stored in the named variable). |
||||||
|
# |
||||||
|
# The execution of 'next' can be done in a loop, or via event |
||||||
|
# processing. |
||||||
|
|
||||||
|
# (b) Basic loop |
||||||
|
# - Create and configure a traversal object. |
||||||
|
# - Run a script for each path, using 'foreach'. |
||||||
|
# This is a convenient standard wrapper around 'next'. |
||||||
|
# |
||||||
|
# The loop properly handles all possible Tcl result codes. |
||||||
|
|
||||||
|
# (c) Non-incremental, non-looping. |
||||||
|
# - Create and configure a traversal object. |
||||||
|
# - Retrieve a list of all paths via 'files'. |
||||||
|
|
||||||
|
# The -prefilter callback is executed for directories. Its result |
||||||
|
# determines if the traverser recurses into the directory or not. |
||||||
|
# The default is to always recurse into all directories. The call- |
||||||
|
# back is invoked with a single argument, the path of the |
||||||
|
# directory. |
||||||
|
# |
||||||
|
# The -filter callback is executed for all paths. Its result |
||||||
|
# determines if the current path is a valid result, and returned |
||||||
|
# by 'next'. The default is to accept all paths as valid. The |
||||||
|
# callback is invoked with a single argument, the path to check. |
||||||
|
|
||||||
|
# The -errorcmd callback is executed for all paths the traverser |
||||||
|
# has trouble with. Like being unable to cd into them, get their |
||||||
|
# status, etc. The default is to ignore any such problems. The |
||||||
|
# callback is invoked with a two arguments, the path for which the |
||||||
|
# error occured, and the error message. Errors thrown by the |
||||||
|
# filter callbacks are handled through this callback too. Errors |
||||||
|
# thrown by the error callback itself are not caught and ignored, |
||||||
|
# but allowed to pass to the caller, usually of 'next'. |
||||||
|
|
||||||
|
# Note: Low-level functionality, version and platform dependent is |
||||||
|
# implemented in procedures, and conditioally defined for optimal |
||||||
|
# use of features, etc. ... |
||||||
|
|
||||||
|
# Note: Traversal is done in depth-first pre-order. |
||||||
|
|
||||||
|
# Note: The options are handled only during |
||||||
|
# construction. Afterward they are read-only and attempts to |
||||||
|
# modify them will cause the system to throw errors. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Implementation |
||||||
|
|
||||||
|
option -filter -default {} -readonly 1 |
||||||
|
option -prefilter -default {} -readonly 1 |
||||||
|
option -errorcmd -default {} -readonly 1 |
||||||
|
|
||||||
|
constructor {basedir args} { |
||||||
|
set _base $basedir |
||||||
|
$self configurelist $args |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method files {} { |
||||||
|
set files {} |
||||||
|
$self foreach f {lappend files $f} |
||||||
|
return $files |
||||||
|
} |
||||||
|
|
||||||
|
method foreach {fvar body} { |
||||||
|
upvar 1 $fvar currentfile |
||||||
|
|
||||||
|
# (Re-)initialize the traversal state on every call. |
||||||
|
$self Init |
||||||
|
|
||||||
|
while {[$self next currentfile]} { |
||||||
|
set code [catch {uplevel 1 $body} result] |
||||||
|
|
||||||
|
# decide what to do upon the return code: |
||||||
|
# |
||||||
|
# 0 - the body executed successfully |
||||||
|
# 1 - the body raised an error |
||||||
|
# 2 - the body invoked [return] |
||||||
|
# 3 - the body invoked [break] |
||||||
|
# 4 - the body invoked [continue] |
||||||
|
# everything else - return and pass on the results |
||||||
|
# |
||||||
|
switch -exact -- $code { |
||||||
|
0 {} |
||||||
|
1 { |
||||||
|
return -errorinfo [::control::ErrorInfoAsCaller uplevel foreach] \ |
||||||
|
-errorcode $::errorCode -code error $result |
||||||
|
} |
||||||
|
3 { |
||||||
|
# FRINK: nocheck |
||||||
|
return |
||||||
|
} |
||||||
|
4 {} |
||||||
|
default { |
||||||
|
return -code $code $result |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method next {fvar} { |
||||||
|
upvar 1 $fvar currentfile |
||||||
|
|
||||||
|
# Initialize on first call. |
||||||
|
if {!$_init} { |
||||||
|
$self Init |
||||||
|
} |
||||||
|
|
||||||
|
# We (still) have valid paths in the result stack, return the |
||||||
|
# next one. |
||||||
|
|
||||||
|
if {[llength $_results]} { |
||||||
|
set top [lindex $_results end] |
||||||
|
set _results [lreplace $_results end end] |
||||||
|
set currentfile $top |
||||||
|
return 1 |
||||||
|
} |
||||||
|
|
||||||
|
# Take the next directory waiting in the processing stack and |
||||||
|
# fill the result stack with all valid files and sub- |
||||||
|
# directories contained in it. Extend the processing queue |
||||||
|
# with all sub-directories not yet seen already (!circular |
||||||
|
# symlinks) and accepted by the prefilter. We stop iterating |
||||||
|
# when we either have no directories to process anymore, or |
||||||
|
# the result stack contains at least one path we can return. |
||||||
|
|
||||||
|
while {[llength $_pending]} { |
||||||
|
set top [lindex $_pending end] |
||||||
|
set _pending [lreplace $_pending end end] |
||||||
|
|
||||||
|
# Directory accessible? Skip if not. |
||||||
|
if {![ACCESS $top]} { |
||||||
|
Error $top "Inacessible directory" |
||||||
|
continue |
||||||
|
} |
||||||
|
|
||||||
|
# Expand the result stack with all files in the directory, |
||||||
|
# modulo filtering. |
||||||
|
|
||||||
|
foreach f [GLOBF $top] { |
||||||
|
if {![Valid $f]} continue |
||||||
|
lappend _results $f |
||||||
|
} |
||||||
|
|
||||||
|
# Expand the result stack with all sub-directories in the |
||||||
|
# directory, modulo filtering. Further expand the |
||||||
|
# processing stack with the same directories, if not seen |
||||||
|
# yet and modulo pre-filtering. |
||||||
|
|
||||||
|
foreach f [GLOBD $top] { |
||||||
|
if { |
||||||
|
[string equal [file tail $f] "."] || |
||||||
|
[string equal [file tail $f] ".."] |
||||||
|
} continue |
||||||
|
|
||||||
|
if {[Valid $f]} { |
||||||
|
lappend _results $f |
||||||
|
} |
||||||
|
|
||||||
|
Enter $top $f |
||||||
|
if {[Cycle $f]} continue |
||||||
|
|
||||||
|
if {[Recurse $f]} { |
||||||
|
lappend _pending $f |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Stop expanding if we have paths to return. |
||||||
|
|
||||||
|
if {[llength $_results]} { |
||||||
|
set top [lindex $_results end] |
||||||
|
set _results [lreplace $_results end end] |
||||||
|
set currentfile $top |
||||||
|
return 1 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Allow re-initialization with next call. |
||||||
|
|
||||||
|
set _init 0 |
||||||
|
return 0 |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Traversal state |
||||||
|
|
||||||
|
# * Initialization flag. Checked in 'next', reset by next when no |
||||||
|
# more files are available. Set in 'Init'. |
||||||
|
# * Base directory (or file) to start the traversal from. |
||||||
|
# * Stack of prefiltered unknown directories waiting for |
||||||
|
# processing, i.e. expansion (TOP at end). |
||||||
|
# * Stack of valid paths waiting to be returned as results. |
||||||
|
# * Set of directories already visited (normalized paths), for |
||||||
|
# detection of circular symbolic links. |
||||||
|
|
||||||
|
variable _init 0 ; # Initialization flag. |
||||||
|
variable _base {} ; # Base directory. |
||||||
|
variable _pending {} ; # Processing stack. |
||||||
|
variable _results {} ; # Result stack. |
||||||
|
|
||||||
|
# sym link handling (to break cycles, while allowing the following of non-cycle links). |
||||||
|
# Notes |
||||||
|
# - path parent tracking is lexical. |
||||||
|
# - path identity tracking is based on the normalized path, i.e. the path with all |
||||||
|
# symlinks resolved. |
||||||
|
# Maps |
||||||
|
# - path -> parent (easier to follow the list than doing dirname's) |
||||||
|
# - path -> normalized (cache to avoid redundant calls of fullnormalize) |
||||||
|
# cycle <=> A parent's normalized form (NF) is identical to the current path's NF |
||||||
|
|
||||||
|
variable _parent -array {} |
||||||
|
variable _norm -array {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Internal helpers. |
||||||
|
|
||||||
|
proc Enter {parent path} { |
||||||
|
#puts ___E|$path |
||||||
|
upvar 1 _parent _parent _norm _norm |
||||||
|
set _parent($path) $parent |
||||||
|
set _norm($path) [fileutil::fullnormalize $path] |
||||||
|
} |
||||||
|
|
||||||
|
proc Cycle {path} { |
||||||
|
upvar 1 _parent _parent _norm _norm |
||||||
|
set nform $_norm($path) |
||||||
|
set paren $_parent($path) |
||||||
|
while {$paren ne {}} { |
||||||
|
if {$_norm($paren) eq $nform} { return yes } |
||||||
|
set paren $_parent($paren) |
||||||
|
} |
||||||
|
return no |
||||||
|
} |
||||||
|
|
||||||
|
method Init {} { |
||||||
|
array unset _parent * |
||||||
|
array unset _norm * |
||||||
|
|
||||||
|
# Path ok as result? |
||||||
|
if {[Valid $_base]} { |
||||||
|
lappend _results $_base |
||||||
|
} |
||||||
|
|
||||||
|
# Expansion allowed by prefilter? |
||||||
|
if {[file isdirectory $_base] && [Recurse $_base]} { |
||||||
|
Enter {} $_base |
||||||
|
lappend _pending $_base |
||||||
|
} |
||||||
|
|
||||||
|
# System is set up now. |
||||||
|
set _init 1 |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc Valid {path} { |
||||||
|
#puts ___V|$path |
||||||
|
upvar 1 options options |
||||||
|
if {![llength $options(-filter)]} {return 1} |
||||||
|
set path [file normalize $path] |
||||||
|
set code [catch {uplevel \#0 [linsert $options(-filter) end $path]} valid] |
||||||
|
if {!$code} {return $valid} |
||||||
|
Error $path $valid |
||||||
|
return 0 |
||||||
|
} |
||||||
|
|
||||||
|
proc Recurse {path} { |
||||||
|
#puts ___X|$path |
||||||
|
upvar 1 options options _norm _norm |
||||||
|
if {![llength $options(-prefilter)]} {return 1} |
||||||
|
set path [file normalize $path] |
||||||
|
set code [catch {uplevel \#0 [linsert $options(-prefilter) end $path]} valid] |
||||||
|
if {!$code} {return $valid} |
||||||
|
Error $path $valid |
||||||
|
return 0 |
||||||
|
} |
||||||
|
|
||||||
|
proc Error {path msg} { |
||||||
|
upvar 1 options options |
||||||
|
if {![llength $options(-errorcmd)]} return |
||||||
|
set path [file normalize $path] |
||||||
|
uplevel \#0 [linsert $options(-errorcmd) end $path $msg] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
## |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## |
||||||
|
|
||||||
|
# The next three helper commands for the traverser depend strongly on |
||||||
|
# the version of Tcl, and partially on the platform. |
||||||
|
|
||||||
|
# 1. In Tcl 8.3 using -types f will return only true files, but not |
||||||
|
# links to files. This changed in 8.4+ where links to files are |
||||||
|
# returned as well. So for 8.3 we have to handle the links |
||||||
|
# separately (-types l) and also filter on our own. |
||||||
|
# Note that Windows file links are hard links which are reported by |
||||||
|
# -types f, but not -types l, so we can optimize that for the two |
||||||
|
# platforms. |
||||||
|
# |
||||||
|
# 2. In Tcl 8.3 we also have a crashing bug in glob (SIGABRT, "stat on |
||||||
|
# a known file") when trying to perform 'glob -types {hidden f}' on |
||||||
|
# a directory without e'x'ecute permissions. We code around by |
||||||
|
# testing if we can cd into the directory (stat might return enough |
||||||
|
# information too (mode), but possibly also not portable). |
||||||
|
# |
||||||
|
# For Tcl 8.2 and 8.4+ glob simply delivers an empty result |
||||||
|
# (-nocomplain), without crashing. For them this command is defined |
||||||
|
# so that the bytecode compiler removes it from the bytecode. |
||||||
|
# |
||||||
|
# This bug made the ACCESS helper necessary. |
||||||
|
# We code around the problem by testing if we can cd into the |
||||||
|
# directory (stat might return enough information too (mode), but |
||||||
|
# possibly also not portable). |
||||||
|
|
||||||
|
if {[package vsatisfies [package present Tcl] 8.5]} { |
||||||
|
# Tcl 8.5+. |
||||||
|
# We have to check readability of "current" on our own, glob |
||||||
|
# changed to error out instead of returning nothing. |
||||||
|
|
||||||
|
proc ::fileutil::traverse::ACCESS {args} {return 1} |
||||||
|
|
||||||
|
proc ::fileutil::traverse::GLOBF {current} { |
||||||
|
if {![file readable $current] || |
||||||
|
[BadLink $current]} { |
||||||
|
return {} |
||||||
|
} |
||||||
|
|
||||||
|
set res [lsort -unique [concat \ |
||||||
|
[glob -nocomplain -directory $current -types f -- *] \ |
||||||
|
[glob -nocomplain -directory $current -types {hidden f} -- *]]] |
||||||
|
|
||||||
|
# Look for broken links (They are reported as neither file nor directory). |
||||||
|
foreach l [lsort -unique [concat \ |
||||||
|
[glob -nocomplain -directory $current -types l -- *] \ |
||||||
|
[glob -nocomplain -directory $current -types {hidden l} -- *]]] { |
||||||
|
if {[file isfile $l]} continue |
||||||
|
if {[file isdirectory $l]} continue |
||||||
|
lappend res $l |
||||||
|
} |
||||||
|
return [lsort -unique $res] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::fileutil::traverse::GLOBD {current} { |
||||||
|
if {![file readable $current] || |
||||||
|
[BadLink $current]} { |
||||||
|
return {} |
||||||
|
} |
||||||
|
|
||||||
|
lsort -unique [concat \ |
||||||
|
[glob -nocomplain -directory $current -types d -- *] \ |
||||||
|
[glob -nocomplain -directory $current -types {hidden d} -- *]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::fileutil::traverse::BadLink {current} { |
||||||
|
if {[file type $current] ne "link"} { return no } |
||||||
|
|
||||||
|
set dst [file join [file dirname $current] [file readlink $current]] |
||||||
|
|
||||||
|
if {![file exists $dst] || |
||||||
|
![file readable $dst]} { |
||||||
|
return yes |
||||||
|
} |
||||||
|
|
||||||
|
return no |
||||||
|
} |
||||||
|
|
||||||
|
} elseif {[package vsatisfies [package present Tcl] 8.4]} { |
||||||
|
# Tcl 8.4+. |
||||||
|
# (Ad 1) We have -directory, and -types, |
||||||
|
# (Ad 2) Links are returned for -types f/d if they refer to files/dirs. |
||||||
|
# (Ad 3) No bug to code around |
||||||
|
|
||||||
|
proc ::fileutil::traverse::ACCESS {args} {return 1} |
||||||
|
|
||||||
|
proc ::fileutil::traverse::GLOBF {current} { |
||||||
|
set res [concat \ |
||||||
|
[glob -nocomplain -directory $current -types f -- *] \ |
||||||
|
[glob -nocomplain -directory $current -types {hidden f} -- *]] |
||||||
|
|
||||||
|
# Look for broken links (They are reported as neither file nor directory). |
||||||
|
foreach l [concat \ |
||||||
|
[glob -nocomplain -directory $current -types l -- *] \ |
||||||
|
[glob -nocomplain -directory $current -types {hidden l} -- *] ] { |
||||||
|
if {[file isfile $l]} continue |
||||||
|
if {[file isdirectory $l]} continue |
||||||
|
lappend res $l |
||||||
|
} |
||||||
|
return $res |
||||||
|
} |
||||||
|
|
||||||
|
proc ::fileutil::traverse::GLOBD {current} { |
||||||
|
concat \ |
||||||
|
[glob -nocomplain -directory $current -types d -- *] \ |
||||||
|
[glob -nocomplain -directory $current -types {hidden d} -- *] |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
# 8.3. |
||||||
|
# (Ad 1) We have -directory, and -types, |
||||||
|
# (Ad 2) Links are NOT returned for -types f/d, collect separately. |
||||||
|
# No symbolic file links on Windows. |
||||||
|
# (Ad 3) Bug to code around. |
||||||
|
|
||||||
|
proc ::fileutil::traverse::ACCESS {current} { |
||||||
|
if {[catch { |
||||||
|
set h [pwd] ; cd $current ; cd $h |
||||||
|
}]} {return 0} |
||||||
|
return 1 |
||||||
|
} |
||||||
|
|
||||||
|
if {[string equal $::tcl_platform(platform) windows]} { |
||||||
|
proc ::fileutil::traverse::GLOBF {current} { |
||||||
|
concat \ |
||||||
|
[glob -nocomplain -directory $current -types f -- *] \ |
||||||
|
[glob -nocomplain -directory $current -types {hidden f} -- *]] |
||||||
|
} |
||||||
|
} else { |
||||||
|
proc ::fileutil::traverse::GLOBF {current} { |
||||||
|
set l [concat \ |
||||||
|
[glob -nocomplain -directory $current -types f -- *] \ |
||||||
|
[glob -nocomplain -directory $current -types {hidden f} -- *]] |
||||||
|
|
||||||
|
foreach x [concat \ |
||||||
|
[glob -nocomplain -directory $current -types l -- *] \ |
||||||
|
[glob -nocomplain -directory $current -types {hidden l} -- *]] { |
||||||
|
if {[file isdirectory $x]} continue |
||||||
|
# We have now accepted files, links to files, and broken links. |
||||||
|
lappend l $x |
||||||
|
} |
||||||
|
|
||||||
|
return $l |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::fileutil::traverse::GLOBD {current} { |
||||||
|
set l [concat \ |
||||||
|
[glob -nocomplain -directory $current -types d -- *] \ |
||||||
|
[glob -nocomplain -directory $current -types {hidden d} -- *]] |
||||||
|
|
||||||
|
foreach x [concat \ |
||||||
|
[glob -nocomplain -directory $current -types l -- *] \ |
||||||
|
[glob -nocomplain -directory $current -types {hidden l} -- *]] { |
||||||
|
if {![file isdirectory $x]} continue |
||||||
|
lappend l $x |
||||||
|
} |
||||||
|
|
||||||
|
return $l |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide fileutil::traverse 0.6 |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,325 @@ |
|||||||
|
package provide funcl [namespace eval funcl { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
}] |
||||||
|
#funcl = function list (nested call structure) |
||||||
|
# |
||||||
|
#a basic functional composition o combinator |
||||||
|
#o(f,g)(x) == f(g(x)) |
||||||
|
|
||||||
|
namespace eval funcl { |
||||||
|
|
||||||
|
#from punk::pipe |
||||||
|
proc arg_is_script_shaped {arg} { |
||||||
|
if {[string first " " $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} elseif {[string first \n $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} elseif {[string first ";" $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} elseif {[string first \t $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc o args { |
||||||
|
set closing [string repeat {]} [expr [llength $args]-1]] |
||||||
|
set body "[join $args { [}] \$data $closing" |
||||||
|
return $body |
||||||
|
} |
||||||
|
|
||||||
|
proc o_ args { |
||||||
|
set body "" |
||||||
|
set tails [lrepeat [llength $args] ""] |
||||||
|
puts stdout "tails: $tails" |
||||||
|
|
||||||
|
set end [lindex $args end] |
||||||
|
if {[llength $end] == 1 && [arg_is_script_shaped $end]} { |
||||||
|
set endfunc [string map "<end> $end" {uplevel 1 [list if 1 <end> ]}] |
||||||
|
} else { |
||||||
|
set endfunc $end |
||||||
|
} |
||||||
|
if {[llength $args] == 1} { |
||||||
|
return $endfunc |
||||||
|
} |
||||||
|
|
||||||
|
set wrap { [} |
||||||
|
append wrap $endfunc |
||||||
|
append wrap { ]} |
||||||
|
|
||||||
|
set i 0 |
||||||
|
foreach cmdlist [lrange $args 0 end-1] { |
||||||
|
set is_script 0 |
||||||
|
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { |
||||||
|
set is_script 1 |
||||||
|
set script [lindex $cmdlist 0] |
||||||
|
} |
||||||
|
set t "" |
||||||
|
if {$i > 0} { |
||||||
|
append body { [} |
||||||
|
} |
||||||
|
set posn [lsearch $cmdlist _] |
||||||
|
if {$posn <= 0} { |
||||||
|
append body $cmdlist |
||||||
|
if {$i == ([llength $args]-2)} { |
||||||
|
append body " $wrap" |
||||||
|
} |
||||||
|
#if {$i == [expr {[llength $args] -2}]} { |
||||||
|
# #append body " \$data" |
||||||
|
# append body " $wrap" |
||||||
|
#} |
||||||
|
if {$i > 0} { |
||||||
|
set t {]} |
||||||
|
} |
||||||
|
} else { |
||||||
|
append body [lrange $cmdlist 0 $posn-1] |
||||||
|
if {$i == ([llength $args] -2)} { |
||||||
|
#append body " \$data" |
||||||
|
append body " $wrap" |
||||||
|
} |
||||||
|
set t [lrange $cmdlist $posn+1 end] |
||||||
|
if {$i > 0} { |
||||||
|
append t { ]} |
||||||
|
} |
||||||
|
} |
||||||
|
lset tails $i $t |
||||||
|
incr i |
||||||
|
} |
||||||
|
append body [join [lreverse $tails] " "] |
||||||
|
puts stdout "tails: $tails" |
||||||
|
|
||||||
|
return $body |
||||||
|
} |
||||||
|
|
||||||
|
#review - consider _call -- if count > 1 then they must all be callable cmdlists(?) |
||||||
|
# what does it mean to have additional _fn wrapper with no other elements? (no actual function) |
||||||
|
#e.g _fn 2 5 6 somefunc {_fn 1 3 {_call 1 3 xxx}} {_fn 1 4 command {_fn ...}} |
||||||
|
# what type indicates running subtrees in parallel vs sequentially? |
||||||
|
# any reason to have _call count other than 1? Presumably the parent node indicates the parallelism/sequentialism etc. |
||||||
|
# |
||||||
|
# |
||||||
|
# accept or return a funcl (or funcltree if multiple funcls in one commandlist) |
||||||
|
# also accept/return a call - return empty list if passed a call |
||||||
|
proc next_funcl {funcl_or_tree} { |
||||||
|
if {[lindex $funcl_or_tree 0] eq "_call"} { |
||||||
|
return [list] |
||||||
|
} |
||||||
|
if {[lindex $funcl_or_tree 0] in [list "_fn" "_call"]} { |
||||||
|
set funcl $funcl_or_tree |
||||||
|
} else { |
||||||
|
error "funcltree not implemented" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set count [lindex $funcl 1] |
||||||
|
if {$count == 0} { |
||||||
|
#null funcl.. what is it? metadata/placeholder? |
||||||
|
return $funcl |
||||||
|
} |
||||||
|
set indices [lrange $funcl 2 [expr {1 + $count}]] |
||||||
|
set i 0 |
||||||
|
foreach idx $indices { |
||||||
|
if {$i > 0} { |
||||||
|
#todo - return a funcltree |
||||||
|
error "multi funcl not implemented" |
||||||
|
} |
||||||
|
set next [lindex $funcl $idx] |
||||||
|
incr i |
||||||
|
} |
||||||
|
|
||||||
|
return $next |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#convert a funcl to a tcl script |
||||||
|
proc funcl_script {funcl} { |
||||||
|
if {![llength $funcl]} { |
||||||
|
return "" |
||||||
|
} |
||||||
|
set body "" |
||||||
|
set tails [list] |
||||||
|
|
||||||
|
set type [lindex $funcl 0] |
||||||
|
if {$type ni [list "_fn" "_call"]} { |
||||||
|
#todo - handle funcltree |
||||||
|
error "type $type not implemented" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#only count of 1 with index 3 supported(?) |
||||||
|
if {$type eq "_call"} { |
||||||
|
#leaf |
||||||
|
set cmdlist [lindex $funcl 3] |
||||||
|
return $cmdlist |
||||||
|
} |
||||||
|
|
||||||
|
#we will use next_funcl to walk the nodes.. todo support treefuncl response from next_funcl which could branch multiple times. |
||||||
|
#by continually passing back the resulting treefuncl/funcl to next_funcl we can process in correct order (?) |
||||||
|
# we would still need to maintain state to stitch it back together once returned from a subtree.. |
||||||
|
# ie multiple tail parts |
||||||
|
set count [lindex $funcl 1] |
||||||
|
|
||||||
|
if {$count == 1} { |
||||||
|
set idx [lindex $funcl 2] |
||||||
|
if {$idx == 3} { |
||||||
|
set cmdlist_pre [list] |
||||||
|
} else { |
||||||
|
set cmdlist_pre [lrange $funcl 3 $idx-1] |
||||||
|
} |
||||||
|
append body $cmdlist_pre |
||||||
|
set t [lrange $funcl $idx+1 end] |
||||||
|
lappend tails $t |
||||||
|
} else { |
||||||
|
#?? |
||||||
|
error "funcl_script branching not yet supported" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set get_next 1 |
||||||
|
set i 1 |
||||||
|
while {$get_next} { |
||||||
|
set funcl [next_funcl $funcl] |
||||||
|
if {![llength $funcl]} { |
||||||
|
set get_next 0 |
||||||
|
} |
||||||
|
lassign $funcl type count idx ;#todo support count > 1 |
||||||
|
if {$type eq "_call"} { |
||||||
|
set get_next 0 |
||||||
|
} |
||||||
|
set t "" |
||||||
|
if {$type eq "_call"} { |
||||||
|
append body { [} |
||||||
|
append body [lindex $funcl $idx] |
||||||
|
append body { ]} |
||||||
|
} else { |
||||||
|
append body { [} |
||||||
|
if {$idx == 3} { |
||||||
|
set cmdlist_pre [list] |
||||||
|
} else { |
||||||
|
set cmdlist_pre [lrange $funcl 3 $idx-1] |
||||||
|
} |
||||||
|
append body $cmdlist_pre |
||||||
|
set t [lrange $funcl $idx+1 end] |
||||||
|
lappend tails $t |
||||||
|
lappend tails { ]} |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
append body [join [lreverse $tails] " "] |
||||||
|
#puts stdout "tails: $tails" |
||||||
|
|
||||||
|
return $body |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
interp alias "" o_of "" funcl::o_of_n 1 |
||||||
|
|
||||||
|
#o_of_n |
||||||
|
#tcl list rep o combinator |
||||||
|
# |
||||||
|
# can take lists of ordinary commandlists, scripts and funcls |
||||||
|
# _fn 1 x where 1 indicates number of subfuncls and where x indicates next funcl position (_fn list or _arg) |
||||||
|
# _fn 0 indicates next item is an unwrapped commandlist (terminal command) |
||||||
|
# |
||||||
|
#o_of is equivalent to o_of_n 1 (1 argument o combinator) |
||||||
|
#last n args are passed to the prior function |
||||||
|
#e.g for n=1 f a b = f(a(b)) |
||||||
|
#e.g for n=2, e f a b = e(f(a b)) |
||||||
|
proc o_of_n {n args} { |
||||||
|
puts stdout "o_of_n '$args'" |
||||||
|
if {$n != 1} { |
||||||
|
error "o_of_n only implemented for 1 sub-funcl" |
||||||
|
} |
||||||
|
set comp [list] ;#composition list |
||||||
|
set end [lindex $args end] |
||||||
|
if {[lindex $end 0] in {_fn _call}]} { |
||||||
|
#is_funcl |
||||||
|
set endfunc [lindex $args end] |
||||||
|
} else { |
||||||
|
if {[llength $end] == 1 && [arg_is_script_shaped $end]} { |
||||||
|
#set endfunc [string map [list <end> $end] {uplevel 1 [list if 1 <end> ]}] |
||||||
|
set endfunc [list _call 1 3 [list uplevel 1 [list if 1 [lindex $end 0]]]] |
||||||
|
} else { |
||||||
|
set endfunc [list _call 1 3 [list {*}$end]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength $args] == 1} { |
||||||
|
return $endfunc |
||||||
|
} |
||||||
|
set comp $endfunc |
||||||
|
set revlist [lreverse [lrange $args 0 end-1]] |
||||||
|
foreach cmdlist $revlist { |
||||||
|
puts stderr "o_of_n >>-- $cmdlist" |
||||||
|
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { |
||||||
|
set is_script 1 |
||||||
|
set script [lindex $cmdlist 0] |
||||||
|
set arglist [list data] |
||||||
|
|
||||||
|
set comp [list _fn 1 6 call_script $script $arglist $comp] |
||||||
|
} else { |
||||||
|
set posn1 [expr {[llength $cmdlist] + 2 + $n}] |
||||||
|
set comp [list _fn $n $posn1 {*}$cmdlist $comp] |
||||||
|
} |
||||||
|
} |
||||||
|
return $comp |
||||||
|
} |
||||||
|
proc call_script {script argnames args} { |
||||||
|
uplevel 3 [list if 1 [list apply [list $argnames $script] {*}$args]] |
||||||
|
} |
||||||
|
proc funcl_script_test {scr} { |
||||||
|
do_funcl_script_test $scr |
||||||
|
} |
||||||
|
proc do_funcl_script_test {scr} { |
||||||
|
#set j "in do_funcl_script_test" |
||||||
|
#set data "xxx" |
||||||
|
#puts '$scr' |
||||||
|
if 1 $scr |
||||||
|
} |
||||||
|
|
||||||
|
#standard o_ with no script-handling |
||||||
|
proc o_plain args { |
||||||
|
set body "" |
||||||
|
set i 0 |
||||||
|
set tails [lrepeat [llength $args] ""] |
||||||
|
#puts stdout "tails: $tails" |
||||||
|
foreach cmdlist $args { |
||||||
|
set t "" |
||||||
|
if {$i > 0} { |
||||||
|
append body { [} |
||||||
|
} |
||||||
|
set posn [lsearch $cmdlist _] |
||||||
|
if {$posn <= 0} { |
||||||
|
append body $cmdlist |
||||||
|
if {$i == ([llength $args] -1)} { |
||||||
|
append body " \$data" |
||||||
|
} |
||||||
|
if {$i > 0} { |
||||||
|
set t {]} |
||||||
|
} |
||||||
|
} else { |
||||||
|
append body [lrange $cmdlist 0 $posn-1] |
||||||
|
if {$i == ([llength $args] -1)} { |
||||||
|
append body " \$data" |
||||||
|
} |
||||||
|
set t [lrange $cmdlist $posn+1 end] |
||||||
|
if {$i > 0} { |
||||||
|
append t { ]} |
||||||
|
} |
||||||
|
} |
||||||
|
lset tails $i $t |
||||||
|
incr i |
||||||
|
} |
||||||
|
append body [join [lreverse $tails] " "] |
||||||
|
#puts stdout "tails: $tails" |
||||||
|
|
||||||
|
return $body |
||||||
|
} |
||||||
|
#timings suggest no faster to split out the first item from the cmdlist loop |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,705 +0,0 @@ |
|||||||
# -*- tcl -*- |
|
||||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
||||||
# |
|
||||||
# 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) 2024 |
|
||||||
# |
|
||||||
# @@ Meta Begin |
|
||||||
# Application modpod 0.1.0 |
|
||||||
# Meta platform tcl |
|
||||||
# Meta license <unspecified> |
|
||||||
# @@ Meta End |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# doctools header |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
#*** !doctools |
|
||||||
#[manpage_begin modpod_module_modpod 0 0.1.0] |
|
||||||
#[copyright "2024"] |
|
||||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
|
||||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
|
||||||
#[require modpod] |
|
||||||
#[keywords module] |
|
||||||
#[description] |
|
||||||
#[para] - |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[section Overview] |
|
||||||
#[para] overview of modpod |
|
||||||
#[subsection Concepts] |
|
||||||
#[para] - |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
## Requirements |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[subsection dependencies] |
|
||||||
#[para] packages used by modpod |
|
||||||
#[list_begin itemized] |
|
||||||
|
|
||||||
package require Tcl 8.6- |
|
||||||
package require struct::set ;#review |
|
||||||
package require punk::lib |
|
||||||
package require punk::args |
|
||||||
#*** !doctools |
|
||||||
#[item] [package {Tcl 8.6-}] |
|
||||||
|
|
||||||
# #package require frobz |
|
||||||
# #*** !doctools |
|
||||||
# #[item] [package {frobz}] |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[section API] |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# oo::class namespace |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
namespace eval modpod::class { |
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace modpod::class}] |
|
||||||
#[para] class definitions |
|
||||||
if {[info commands [namespace current]::interface_sample1] eq ""} { |
|
||||||
#*** !doctools |
|
||||||
#[list_begin enumerated] |
|
||||||
|
|
||||||
# oo::class create interface_sample1 { |
|
||||||
# #*** !doctools |
|
||||||
# #[enum] CLASS [class interface_sample1] |
|
||||||
# #[list_begin definitions] |
|
||||||
|
|
||||||
# method test {arg1} { |
|
||||||
# #*** !doctools |
|
||||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
|
||||||
# #[para] test method |
|
||||||
# puts "test: $arg1" |
|
||||||
# } |
|
||||||
|
|
||||||
# #*** !doctools |
|
||||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
|
||||||
# } |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] [comment {--- end class enumeration ---}] |
|
||||||
} |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# Base namespace |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
namespace eval modpod { |
|
||||||
namespace export {[a-z]*}; # Convention: export all lowercase |
|
||||||
|
|
||||||
variable connected |
|
||||||
if {![info exists connected(to)]} { |
|
||||||
set connected(to) list |
|
||||||
} |
|
||||||
variable modpodscript |
|
||||||
set modpodscript [info script] |
|
||||||
if {[string tolower [file extension $modpodscript]] eq ".tcl"} { |
|
||||||
set connected(self) [file dirname $modpodscript] |
|
||||||
} else { |
|
||||||
#expecting a .tm |
|
||||||
set connected(self) $modpodscript |
|
||||||
} |
|
||||||
variable loadables [info sharedlibextension] |
|
||||||
variable sourceables {.tcl .tk} ;# .tm ? |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace modpod}] |
|
||||||
#[para] Core API functions for modpod |
|
||||||
#[list_begin definitions] |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#proc sample1 {p1 args} { |
|
||||||
# #*** !doctools |
|
||||||
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
|
||||||
# #[para]Description of sample1 |
|
||||||
# return "ok" |
|
||||||
#} |
|
||||||
|
|
||||||
proc connect {args} { |
|
||||||
puts stderr "modpod::connect--->>$args" |
|
||||||
set argd [punk::args::get_dict { |
|
||||||
-type -default "" |
|
||||||
*values -min 1 -max 1 |
|
||||||
path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" |
|
||||||
} $args] |
|
||||||
catch { |
|
||||||
punk::lib::showdict $argd ;#heavy dependencies |
|
||||||
} |
|
||||||
set opt_path [dict get $argd values path] |
|
||||||
variable connected |
|
||||||
set original_connectpath $opt_path |
|
||||||
set modpodpath [modpod::system::normalize $opt_path] ;# |
|
||||||
|
|
||||||
if {$modpodpath in $connected(to)} { |
|
||||||
return [dict create ok ALREADY_CONNECTED] |
|
||||||
} |
|
||||||
lappend connected(to) $modpodpath |
|
||||||
|
|
||||||
set connected(connectpath,$opt_path) $original_connectpath |
|
||||||
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info_script]]}] |
|
||||||
|
|
||||||
set connected(location,$modpodpath) [file dirname $modpodpath] |
|
||||||
set connected(startdata,$modpodpath) -1 |
|
||||||
set connected(type,$modpodpath) [dict get $argd-opts -type] |
|
||||||
set connected(fh,$modpodpath) "" |
|
||||||
|
|
||||||
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { |
|
||||||
set connected(type,$modpodpath) "unwrapped" |
|
||||||
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
|
||||||
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] |
|
||||||
|
|
||||||
} else { |
|
||||||
#connect to .tm but may still be unwrapped version available |
|
||||||
lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
|
||||||
set this_pkg_tm_folder [file dirname $modpodpath] |
|
||||||
if {$connected(type,$modpodpath) ne "unwrapped"} { |
|
||||||
#Not directly connected to unwrapped version - but may still be redirected there |
|
||||||
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] |
|
||||||
if {[file exists $unwrappedFolder]} { |
|
||||||
#folder with exact version-match must exist for redirect to 'unwrapped' |
|
||||||
set con(type,$modpodpath) "modpod-redirecting" |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
} |
|
||||||
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" |
|
||||||
set connected(tmfile,$modpodpath) |
|
||||||
set tail_segments [list] |
|
||||||
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] |
|
||||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
|
||||||
foreach lc_mpath $lcase_modulepaths { |
|
||||||
set mpath_segments [file split $lc_mpath] |
|
||||||
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
|
||||||
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
if {[llength $tail_segments]} { |
|
||||||
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require |
|
||||||
} else { |
|
||||||
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] |
|
||||||
} |
|
||||||
|
|
||||||
switch -exact -- $connected(type,$modpodpath) { |
|
||||||
"modpod-redirecting" { |
|
||||||
#redirect to the unwrapped version |
|
||||||
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] |
|
||||||
|
|
||||||
} |
|
||||||
"unwrapped" { |
|
||||||
if {[info commands ::thread::id] ne ""} { |
|
||||||
set from [pid],[thread::id] |
|
||||||
} else { |
|
||||||
set from [pid] |
|
||||||
} |
|
||||||
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" |
|
||||||
return [list ok ""] |
|
||||||
} |
|
||||||
default { |
|
||||||
#autodetect .tm - zip/tar ? |
|
||||||
#todo - use vfs ? |
|
||||||
|
|
||||||
#connect to tarball - start at 1st header |
|
||||||
set connected(startdata,$modpodpath) 0 |
|
||||||
set fh [open $modpodpath r] |
|
||||||
set connected(fh,$modpodpath) $fh |
|
||||||
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} |
|
||||||
|
|
||||||
if {$connected(startdata,$modpodpath) >= 0} { |
|
||||||
#verify we have a valid tar header |
|
||||||
if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { |
|
||||||
seek $fh $connected(startdata,$modpodpath) start |
|
||||||
return [list ok $fh] |
|
||||||
} else { |
|
||||||
#error "cannot verify tar header" |
|
||||||
} |
|
||||||
} |
|
||||||
lpop connected(to) end |
|
||||||
set connected(startdata,$modpodpath) -1 |
|
||||||
unset connected(fh,$modpodpath) |
|
||||||
catch {close $fh} |
|
||||||
return [dict create err {Does not appear to be a valid modpod}] |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
proc disconnect {{modpod ""}} { |
|
||||||
variable connected |
|
||||||
if {![llength $connected(to)]} { |
|
||||||
return 0 |
|
||||||
} |
|
||||||
if {$modpod eq ""} { |
|
||||||
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" |
|
||||||
set modpod [lindex $connected(to) end] |
|
||||||
} |
|
||||||
|
|
||||||
if {[set posn [lsearch $connected(to) $modpod]] == -1} { |
|
||||||
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" |
|
||||||
return 0 |
|
||||||
} |
|
||||||
if {[string length $connected(fh,$modpod)]} { |
|
||||||
close $connected(fh,$modpod) |
|
||||||
} |
|
||||||
array unset connected *,$modpod |
|
||||||
set connected(to) [lreplace $connected(to) $posn $posn] |
|
||||||
return 1 |
|
||||||
} |
|
||||||
proc get {args} { |
|
||||||
set argd [punk::args::get_dict { |
|
||||||
-from -default "" -help "path to pod" |
|
||||||
*values -min 1 -max 1 |
|
||||||
filename |
|
||||||
} $args] |
|
||||||
set frompod [dict get $argd opts -from] |
|
||||||
set filename [dict get $argd values filename] |
|
||||||
|
|
||||||
variable connected |
|
||||||
set modpod [::tarjar::system::connect_if_not $frompod] |
|
||||||
set fh $connected(fh,$modpod) |
|
||||||
if {$connected(type,$modpod) eq "unwrapped"} { |
|
||||||
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder |
|
||||||
if {[string range $filename 0 0 eq "/"]} { |
|
||||||
#absolute path (?) |
|
||||||
set path [file join $connected(location,$modpod) .. [string trim $filename /]] |
|
||||||
} else { |
|
||||||
#relative path - use #modpod-xxx as base |
|
||||||
set path [file join $connected(location,$modpod) $filename] |
|
||||||
} |
|
||||||
set fd [open $path r] |
|
||||||
#utf-8? |
|
||||||
#fconfigure $fd -encoding iso8859-1 -translation binary |
|
||||||
return [list ok [lindex [list [read $fd] [close $fd]] 0]] |
|
||||||
} else { |
|
||||||
#read from vfs |
|
||||||
puts stderr "get $filename from wrapped pod '$frompod' not implemented" |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] [comment {--- end definitions namespace modpod ---}] |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# Secondary API namespace |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
namespace eval modpod::lib { |
|
||||||
namespace export {[a-z]*}; # Convention: export all lowercase |
|
||||||
namespace path [namespace parent] |
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace modpod::lib}] |
|
||||||
#[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 |
|
||||||
#} |
|
||||||
|
|
||||||
proc is_valid_tm_version {versionpart} { |
|
||||||
#Needs to be suitable for use with Tcl's 'package vcompare' |
|
||||||
if {![catch [list package vcompare $versionparts $versionparts]]} { |
|
||||||
return 1 |
|
||||||
} else { |
|
||||||
return 0 |
|
||||||
} |
|
||||||
} |
|
||||||
proc make_zip_modpod {zipfile outfile} { |
|
||||||
set mount_stub { |
|
||||||
#zip file with Tcl loader prepended. |
|
||||||
#generated using modpod::make_zip_modpod |
|
||||||
if {[catch {file normalize [info script]} modfile]} { |
|
||||||
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
|
||||||
} |
|
||||||
if {$modfile eq "" || ![file exists $modfile]} { |
|
||||||
error "modpod zip stub error. Unable to determine module path" |
|
||||||
} |
|
||||||
set moddir [file dirname $modfile] |
|
||||||
set mod_and_ver [file rootname [file tail $modfile]] |
|
||||||
lassign [split $mod_and_ver -] moduletail version |
|
||||||
if {[file exists $moddir/#modpod-$mod_and_ver]} { |
|
||||||
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm |
|
||||||
} else { |
|
||||||
#determine module namespace so we can mount appropriately |
|
||||||
proc intersect {A B} { |
|
||||||
if {[llength $A] == 0} {return {}} |
|
||||||
if {[llength $B] == 0} {return {}} |
|
||||||
if {[llength $B] > [llength $A]} { |
|
||||||
set res $A |
|
||||||
set A $B |
|
||||||
set B $res |
|
||||||
} |
|
||||||
set res {} |
|
||||||
foreach x $A {set ($x) {}} |
|
||||||
foreach x $B { |
|
||||||
if {[info exists ($x)]} { |
|
||||||
lappend res $x |
|
||||||
} |
|
||||||
} |
|
||||||
return $res |
|
||||||
} |
|
||||||
set lcase_tmfile_segments [string tolower [file split $moddir]] |
|
||||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
|
||||||
foreach lc_mpath $lcase_modulepaths { |
|
||||||
set mpath_segments [file split $lc_mpath] |
|
||||||
if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
|
||||||
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use propertly cased tail |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
if {[llength $tail_segments]} { |
|
||||||
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require |
|
||||||
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver |
|
||||||
} else { |
|
||||||
set fullpackage $moduletail |
|
||||||
set mount_at #modpod/#mounted-modpod-$mod_and_ver |
|
||||||
} |
|
||||||
|
|
||||||
if {[info commands tcl::zipfs::mount] ne ""} { |
|
||||||
#argument order changed to be consistent with vfs::zip::Mount etc |
|
||||||
#early versions: zipfs::Mount mountpoint zipname |
|
||||||
#since 2023-09: zipfs::Mount zipname mountpoint |
|
||||||
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) |
|
||||||
#This is presumably related to // being interpreted as a network path |
|
||||||
set mountpoints [dict keys [tcl::zipfs::mount]] |
|
||||||
if {"//zipfs:/$mount_at" ni $mountpoints} { |
|
||||||
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it |
|
||||||
if {[catch { |
|
||||||
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) |
|
||||||
#puts "tcl::zipfs::mount $modfile $mount_at" |
|
||||||
tcl::zipfs::mount $modfile $mount_at |
|
||||||
} errM]} { |
|
||||||
#try old api |
|
||||||
if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { |
|
||||||
puts stderr "modpod stub>>> tcl::zipfs::mount <file> <mountpoint> failed.\nbut old api: tcl::zipfs::mount <mountpoint> <file> succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" |
|
||||||
puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" |
|
||||||
} |
|
||||||
} |
|
||||||
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
|
||||||
puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" |
|
||||||
#tcl::zipfs::unmount //zipfs:/$mount_at |
|
||||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
|
||||||
} |
|
||||||
} |
|
||||||
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form |
|
||||||
source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
|
||||||
} else { |
|
||||||
#fallback to slower vfs::zip |
|
||||||
#NB. We don't create the intermediate dirs - but the mount still works |
|
||||||
if {![file exists $moddir/$mount_at]} { |
|
||||||
if {[catch {package require vfs::zip} errM]} { |
|
||||||
set msg "Unable to load vfs::zip package to mount module $mod_and_ver" |
|
||||||
append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place." |
|
||||||
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" |
|
||||||
error $msg |
|
||||||
} else { |
|
||||||
set fd [vfs::zip::Mount $modfile $moddir/$mount_at] |
|
||||||
if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
|
||||||
vfs::zip::Unmount $fd $moddir/$mount_at |
|
||||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
|
||||||
} |
|
||||||
} |
|
||||||
#zipped data follows |
|
||||||
} |
|
||||||
#todo - test if zipfile has #modpod-loadcript.tcl before even creating |
|
||||||
append mount_stub \x1A |
|
||||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub |
|
||||||
|
|
||||||
} |
|
||||||
proc make_zip_modpod1 {zipfile outfile} { |
|
||||||
set mount_stub { |
|
||||||
#zip file with Tcl loader prepended. |
|
||||||
#generated using modpod::make_zip_modpod |
|
||||||
if {[catch {file normalize [info script]} modfile]} { |
|
||||||
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
|
||||||
} |
|
||||||
if {$modfile eq "" || ![file exists $modfile]} { |
|
||||||
error "modpod zip stub error. Unable to determine module path" |
|
||||||
} |
|
||||||
set moddir [file dirname $modfile] |
|
||||||
set mod_and_ver [file rootname [file tail $modfile]] |
|
||||||
lassign [split $mod_and_ver -] moduletail version |
|
||||||
if {[file exists $moddir/#modpod-$mod_and_ver]} { |
|
||||||
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm |
|
||||||
} else { |
|
||||||
if {![file exists $moddir/#mounted-modpod-$mod_and_ver]} { |
|
||||||
if {[catch {package require vfs::zip} errM]} { |
|
||||||
set msg "Unable to load vfs::zip package to mount module $mod_and_ver" |
|
||||||
append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place." |
|
||||||
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $ |
|
||||||
} |
|
||||||
set fd [vfs::zip::Mount $modfile $moddir/#mounted-modpod-$mod_and_ver] |
|
||||||
if {![file exists $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
|
||||||
vfs::zip::Unmount $fd $moddir/#mounted-modpod-$mod_and_ver |
|
||||||
error "Unable to find #modpod-$mod_and_ver/$mod_and_ver.tm in $modfile" |
|
||||||
} |
|
||||||
} |
|
||||||
source $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm |
|
||||||
} |
|
||||||
#zipped data follows |
|
||||||
} |
|
||||||
#todo - test if zipfile has #modpod-loadcript.tcl before even creating |
|
||||||
append mount_stub \x1A |
|
||||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub |
|
||||||
|
|
||||||
} |
|
||||||
proc make_zip_source_mountable {zipfile outfile} { |
|
||||||
set mount_stub { |
|
||||||
package require vfs::zip |
|
||||||
vfs::zip::Mount [info script] [info script] |
|
||||||
} |
|
||||||
append mount_stub \x1A |
|
||||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub |
|
||||||
} |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] [comment {--- end definitions namespace modpod::lib ---}] |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
#*** !doctools |
|
||||||
#[section Internal] |
|
||||||
namespace eval modpod::system { |
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace modpod::system}] |
|
||||||
#[para] Internal functions that are not part of the API |
|
||||||
|
|
||||||
#deflate,store only supported |
|
||||||
proc make_mountable_zip {zipfile outfile mount_stub} { |
|
||||||
set in [open $zipfile r] |
|
||||||
fconfigure $in -encoding iso8859-1 -translation binary |
|
||||||
set out [open $outfile w+] |
|
||||||
fconfigure $out -encoding iso8859-1 -translation binary |
|
||||||
puts -nonewline $out $mount_stub |
|
||||||
set offset [tell $out] |
|
||||||
lappend report "sfx stub size: $offset" |
|
||||||
fcopy $in $out |
|
||||||
|
|
||||||
close $in |
|
||||||
set size [tell $out] |
|
||||||
#Now seek in $out to find the end of directory signature: |
|
||||||
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text |
|
||||||
if {$size < 65559} { |
|
||||||
set seek 0 |
|
||||||
} else { |
|
||||||
set seek [expr {$size - 65559}] |
|
||||||
} |
|
||||||
seek $out $seek |
|
||||||
set data [read $out] |
|
||||||
set start_of_end [string last "\x50\x4b\x05\x06" $data] |
|
||||||
#set start_of_end [expr {$start_of_end + $seek}] |
|
||||||
incr start_of_end $seek |
|
||||||
|
|
||||||
lappend report "START-OF-END: $start_of_end ([expr {$start_of_end - $size}]) [string length $data]" |
|
||||||
|
|
||||||
seek $out $start_of_end |
|
||||||
set end_of_ctrl_dir [read $out] |
|
||||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
|
||||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
|
||||||
|
|
||||||
lappend report "End of central directory: [array get eocd]" |
|
||||||
seek $out [expr {$start_of_end+16}] |
|
||||||
|
|
||||||
#adjust offset of start of central directory by the length of our sfx stub |
|
||||||
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $offset}]] |
|
||||||
flush $out |
|
||||||
|
|
||||||
seek $out $start_of_end |
|
||||||
set end_of_ctrl_dir [read $out] |
|
||||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
|
||||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
|
||||||
|
|
||||||
# 0x06054b50 - end of central dir signature |
|
||||||
puts stderr "$end_of_ctrl_dir" |
|
||||||
puts stderr "comment_len: $eocd(comment_len)" |
|
||||||
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" |
|
||||||
lappend report "New dir offset: $eocd(diroffset)" |
|
||||||
lappend report "Adjusting $eocd(totalnum) zip file items." |
|
||||||
catch { |
|
||||||
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies |
|
||||||
} |
|
||||||
|
|
||||||
seek $out $eocd(diroffset) |
|
||||||
for {set i 0} {$i <$eocd(totalnum)} {incr i} { |
|
||||||
set current_file [tell $out] |
|
||||||
set fileheader [read $out 46] |
|
||||||
puts -------------- |
|
||||||
puts [ansistring VIEW -lf 1 $fileheader] |
|
||||||
puts -------------- |
|
||||||
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
|
||||||
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
|
||||||
|
|
||||||
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
|
||||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
|
||||||
set ::last_header $fileheader |
|
||||||
|
|
||||||
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" |
|
||||||
puts "ver: $x(version)" |
|
||||||
puts "method: $x(method)" |
|
||||||
|
|
||||||
#33639248 dec = 0x02014b50 - central file header signature |
|
||||||
if { $x(sig) != 33639248 } { |
|
||||||
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" |
|
||||||
} |
|
||||||
|
|
||||||
foreach size $x(lengths) var {filename extrafield comment} { |
|
||||||
if { $size > 0 } { |
|
||||||
set x($var) [read $out $size] |
|
||||||
} else { |
|
||||||
set x($var) "" |
|
||||||
} |
|
||||||
} |
|
||||||
set next_file [tell $out] |
|
||||||
lappend report "file $i: $x(offset) $x(sizes) $x(filename)" |
|
||||||
|
|
||||||
seek $out [expr {$current_file+42}] |
|
||||||
puts -nonewline $out [binary format i [expr {$x(offset)+$offset}]] |
|
||||||
|
|
||||||
#verify: |
|
||||||
flush $out |
|
||||||
seek $out $current_file |
|
||||||
set fileheader [read $out 46] |
|
||||||
lappend report "old $x(offset) + $offset" |
|
||||||
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
|
||||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
|
||||||
lappend report "new $x(offset)" |
|
||||||
|
|
||||||
seek $out $next_file |
|
||||||
} |
|
||||||
close $out |
|
||||||
#pdict/showdict reuire punk & textlib - ie lots of dependencies |
|
||||||
#don't fall over just because of that |
|
||||||
catch { |
|
||||||
punk::lib::showdict -roottype list -chan stderr $report |
|
||||||
} |
|
||||||
#puts [join $report \n] |
|
||||||
return |
|
||||||
} |
|
||||||
|
|
||||||
proc connect_if_not {{podpath ""}} { |
|
||||||
upvar ::modpod::connected connected |
|
||||||
set podpath [::modpod::system::normalize $podpath] |
|
||||||
set docon 0 |
|
||||||
if {![llength $connected(to)]} { |
|
||||||
if {![string length $podpath]} { |
|
||||||
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" |
|
||||||
} else { |
|
||||||
set docon 1 |
|
||||||
} |
|
||||||
} else { |
|
||||||
if {![string length $podpath]} { |
|
||||||
set podpath [lindex $connected(to) end] |
|
||||||
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" |
|
||||||
} else { |
|
||||||
if {$podpath ni $connected(to)} { |
|
||||||
set docon 1 |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
if {$docon} { |
|
||||||
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { |
|
||||||
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" |
|
||||||
} else { |
|
||||||
return $podpath |
|
||||||
} |
|
||||||
} |
|
||||||
#we were already connected |
|
||||||
return $podpath |
|
||||||
} |
|
||||||
|
|
||||||
proc myversion {} { |
|
||||||
upvar ::modpod::connected connected |
|
||||||
set script [info script] |
|
||||||
if {![string length $script]} { |
|
||||||
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" |
|
||||||
} |
|
||||||
set fname [file tail [file rootname [file normalize $script]]] |
|
||||||
set scriptdir [file dirname $script] |
|
||||||
|
|
||||||
if {![string match "#modpod-*" $fname]} { |
|
||||||
lassign [lrange [split $fname -] end-1 end] _pkgname version |
|
||||||
} else { |
|
||||||
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version |
|
||||||
if {![string length $version]} { |
|
||||||
#try again on the name of the containing folder |
|
||||||
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version |
|
||||||
#todo - proper walk up the directory tree |
|
||||||
if {![string length $version]} { |
|
||||||
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) |
|
||||||
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
#tarjar::Log debug "'myversion' determined version for [info script]: $version" |
|
||||||
return $version |
|
||||||
} |
|
||||||
|
|
||||||
proc myname {} { |
|
||||||
upvar ::modpod::connected connected |
|
||||||
set script [info script] |
|
||||||
if {![string length $script]} { |
|
||||||
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" |
|
||||||
} |
|
||||||
return $connected(fullpackage,$script) |
|
||||||
} |
|
||||||
proc myfullname {} { |
|
||||||
upvar ::modpod::connected connected |
|
||||||
set script [info script] |
|
||||||
#set script [::tarjar::normalize $script] |
|
||||||
set script [file normalize $script] |
|
||||||
if {![string length $script]} { |
|
||||||
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" |
|
||||||
} |
|
||||||
return $::tarjar::connected(fullpackage,$script) |
|
||||||
} |
|
||||||
proc normalize {path} { |
|
||||||
#newer versions of Tcl don't do tilde sub |
|
||||||
|
|
||||||
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) |
|
||||||
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. |
|
||||||
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. |
|
||||||
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after |
|
||||||
set path [file normalize $path] |
|
||||||
#set path [string tolower $path] ;#must do this after file normalize |
|
||||||
return [string map [list $matilda ~] $path] ;#get our tildes back. |
|
||||||
} |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
## Ready |
|
||||||
package provide modpod [namespace eval modpod { |
|
||||||
variable pkg modpod |
|
||||||
variable version |
|
||||||
set version 0.1.0 |
|
||||||
}] |
|
||||||
return |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[manpage_end] |
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,645 @@ |
|||||||
|
package provide patterncmd [namespace eval patterncmd { |
||||||
|
variable version |
||||||
|
|
||||||
|
set version 1.2.4 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
|
namespace eval pattern { |
||||||
|
variable idCounter 1 ;#used by pattern::uniqueKey |
||||||
|
|
||||||
|
namespace eval cmd { |
||||||
|
namespace eval util { |
||||||
|
package require overtype |
||||||
|
variable colwidths_lib [dict create] |
||||||
|
variable colwidths_lib_default 15 |
||||||
|
|
||||||
|
dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] |
||||||
|
dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] |
||||||
|
dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] |
||||||
|
dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] |
||||||
|
|
||||||
|
proc colhead {type args} { |
||||||
|
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths |
||||||
|
set line "" |
||||||
|
foreach colname [dict keys $colwidths] { |
||||||
|
append line "[col $type $colname [string totitle $colname] {*}$args]" |
||||||
|
} |
||||||
|
return $line |
||||||
|
} |
||||||
|
proc colbreak {type} { |
||||||
|
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths |
||||||
|
set line "" |
||||||
|
foreach colname [dict keys $colwidths] { |
||||||
|
append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" |
||||||
|
} |
||||||
|
return $line |
||||||
|
} |
||||||
|
proc col {type col val args} { |
||||||
|
# args -head bool -tail bool ? |
||||||
|
#---------------------------------------------------------------------------- |
||||||
|
set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] |
||||||
|
dict set default -backchar "" |
||||||
|
dict set default -headchar "" |
||||||
|
dict set default -tailchar "" |
||||||
|
dict set default -headoverridechar "" |
||||||
|
dict set default -tailoverridechar "" |
||||||
|
dict set default -justify "left" |
||||||
|
if {([llength $args] % 2) != 0} { |
||||||
|
error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " |
||||||
|
} |
||||||
|
foreach {k v} $args { |
||||||
|
if {$k ni $known_opts} { |
||||||
|
error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" |
||||||
|
} |
||||||
|
} |
||||||
|
set opts [dict merge $default $args] |
||||||
|
set backchar [dict get $opts -backchar] |
||||||
|
set headchar [dict get $opts -headchar] |
||||||
|
set tailchar [dict get $opts -tailchar] |
||||||
|
set headoverridechar [dict get $opts -headoverridechar] |
||||||
|
set tailoverridechar [dict get $opts -tailoverridechar] |
||||||
|
set justify [dict get $opts -justify] |
||||||
|
#---------------------------------------------------------------------------- |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths |
||||||
|
#calculate headwidths |
||||||
|
set headwidth 0 |
||||||
|
set tailwidth 0 |
||||||
|
foreach {key def} $colwidths { |
||||||
|
set thisheadlen [string length [dict get $def head]] |
||||||
|
if {$thisheadlen > $headwidth} { |
||||||
|
set headwidth $thisheadlen |
||||||
|
} |
||||||
|
set thistaillen [string length [dict get $def tail]] |
||||||
|
if {$thistaillen > $tailwidth} { |
||||||
|
set tailwidth $thistaillen |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set spec [dict get $colwidths $col] |
||||||
|
if {[string length $backchar]} { |
||||||
|
set ch $backchar |
||||||
|
} else { |
||||||
|
set ch [dict get $spec ch] |
||||||
|
} |
||||||
|
set num [dict get $spec num] |
||||||
|
set headchar [dict get $spec head] |
||||||
|
set tailchar [dict get $spec tail] |
||||||
|
|
||||||
|
if {[string length $headchar]} { |
||||||
|
set headchar $headchar |
||||||
|
} |
||||||
|
if {[string length $tailchar]} { |
||||||
|
set tailchar $tailchar |
||||||
|
} |
||||||
|
#overrides only apply if the head/tail has a length |
||||||
|
if {[string length $headchar]} { |
||||||
|
if {[string length $headoverridechar]} { |
||||||
|
set headchar $headoverridechar |
||||||
|
} |
||||||
|
} |
||||||
|
if {[string length $tailchar]} { |
||||||
|
if {[string length $tailoverridechar]} { |
||||||
|
set tailchar $tailoverridechar |
||||||
|
} |
||||||
|
} |
||||||
|
set head [string repeat $headchar $headwidth] |
||||||
|
set tail [string repeat $tailchar $tailwidth] |
||||||
|
|
||||||
|
set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] |
||||||
|
if {$justify eq "left"} { |
||||||
|
set left_done [overtype::left $base "$head$val"] |
||||||
|
return [overtype::right $left_done "$tail"] |
||||||
|
} elseif {$justify in {centre center}} { |
||||||
|
set mid_done [overtype::centre $base $val] |
||||||
|
set left_mid_done [overtype::left $mid_done $head] |
||||||
|
return [overtype::right $left_mid_done $tail] |
||||||
|
} else { |
||||||
|
set right_done [overtype::right $base "$val$tail"] |
||||||
|
return [overtype::left $right_done $head] |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#package require pattern |
||||||
|
|
||||||
|
proc ::pattern::libs {} { |
||||||
|
set libs [list \ |
||||||
|
pattern {-type core -note "alternative:pattern2"}\ |
||||||
|
pattern2 {-type core -note "alternative:pattern"}\ |
||||||
|
patterncmd {-type core}\ |
||||||
|
metaface {-type core}\ |
||||||
|
patternpredator2 {-type core}\ |
||||||
|
patterndispatcher {-type core}\ |
||||||
|
patternlib {-type core}\ |
||||||
|
patterncipher {-type optional -note optional}\ |
||||||
|
] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
package require overtype |
||||||
|
set result "" |
||||||
|
|
||||||
|
append result "[cmd::util::colbreak lib]\n" |
||||||
|
append result "[cmd::util::colhead lib -justify centre]\n" |
||||||
|
append result "[cmd::util::colbreak lib]\n" |
||||||
|
foreach libname [dict keys $libs] { |
||||||
|
set libinfo [dict get $libs $libname] |
||||||
|
|
||||||
|
append result [cmd::util::col lib library $libname] |
||||||
|
if {[catch [list package present $libname] ver]} { |
||||||
|
append result [cmd::util::col lib version "N/A"] |
||||||
|
} else { |
||||||
|
append result [cmd::util::col lib version $ver] |
||||||
|
} |
||||||
|
append result [cmd::util::col lib type [dict get $libinfo -type]] |
||||||
|
|
||||||
|
if {[dict exists $libinfo -note]} { |
||||||
|
set note [dict get $libinfo -note] |
||||||
|
} else { |
||||||
|
set note "" |
||||||
|
} |
||||||
|
append result [cmd::util::col lib note $note] |
||||||
|
append result "\n" |
||||||
|
} |
||||||
|
append result "[cmd::util::colbreak lib]\n" |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::record {recname fields} { |
||||||
|
if {[uplevel 1 [list namespace which $recname]] ne ""} { |
||||||
|
error "(pattern::record) Can't create command '$recname': A command of that name already exists" |
||||||
|
} |
||||||
|
|
||||||
|
set index -1 |
||||||
|
set accessor [list ::apply { |
||||||
|
{index rec args} |
||||||
|
{ |
||||||
|
if {[llength $args] == 0} { |
||||||
|
return [lindex $rec $index] |
||||||
|
} |
||||||
|
if {[llength $args] == 1} { |
||||||
|
return [lreplace $rec $index $index [lindex $args 0]] |
||||||
|
} |
||||||
|
error "Invalid number of arguments." |
||||||
|
} |
||||||
|
|
||||||
|
}] |
||||||
|
|
||||||
|
set map {} |
||||||
|
foreach field $fields { |
||||||
|
dict set map $field [linsert $accessor end [incr index]] |
||||||
|
} |
||||||
|
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] |
||||||
|
} |
||||||
|
proc ::pattern::record2 {recname fields} { |
||||||
|
if {[uplevel 1 [list namespace which $recname]] ne ""} { |
||||||
|
error "(pattern::record) Can't create command '$recname': A command of that name already exists" |
||||||
|
} |
||||||
|
|
||||||
|
set index -1 |
||||||
|
set accessor [list ::apply] |
||||||
|
|
||||||
|
set template { |
||||||
|
{rec args} |
||||||
|
{ |
||||||
|
if {[llength $args] == 0} { |
||||||
|
return [lindex $rec %idx%] |
||||||
|
} |
||||||
|
if {[llength $args] == 1} { |
||||||
|
return [lreplace $rec %idx% %idx% [lindex $args 0]] |
||||||
|
} |
||||||
|
error "Invalid number of arguments." |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set map {} |
||||||
|
foreach field $fields { |
||||||
|
set body [string map [list %idx% [incr index]] $template] |
||||||
|
dict set map $field [list ::apply $body] |
||||||
|
} |
||||||
|
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::argstest {args} { |
||||||
|
package require cmdline |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::objects {} { |
||||||
|
set result [::list] |
||||||
|
|
||||||
|
foreach ns [namespace children ::pp] { |
||||||
|
#lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] |
||||||
|
set ch [namespace tail $ns] |
||||||
|
if {[string range $ch 0 2] eq "Obj"} { |
||||||
|
set OID [string range $ch 3 end] ;#OID need not be digits (!?) |
||||||
|
lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::name {num} { |
||||||
|
#!todo - fix |
||||||
|
#set ::p::${num}::(self) |
||||||
|
|
||||||
|
lassign [interp alias {} ::p::$num] _predator info |
||||||
|
if {![string length $_predator$info]} { |
||||||
|
error "No object found for num:$num (no interp alias for ::p::$num)" |
||||||
|
} |
||||||
|
set invocants [dict get $info i] |
||||||
|
set invocants_with_role_this [dict get $invocants this] |
||||||
|
set invocant_this [lindex $invocants_with_role_this 0] |
||||||
|
|
||||||
|
|
||||||
|
#lassign $invocant_this id info |
||||||
|
#set map [dict get $info map] |
||||||
|
#set fields [lindex $map 0] |
||||||
|
lassign $invocant_this _id _ns _defaultmethod name _etc |
||||||
|
return $name |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::with {cmd script} { |
||||||
|
foreach c [info commands ::p::-1::*] { |
||||||
|
interp alias {} [namespace tail $c] {} $c $cmd |
||||||
|
} |
||||||
|
interp alias {} . {} $cmd . |
||||||
|
interp alias {} .. {} $cmd .. |
||||||
|
|
||||||
|
return [uplevel 1 $script] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#system diagnostics etc |
||||||
|
|
||||||
|
proc ::pattern::varspace_list {IID} { |
||||||
|
namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables |
||||||
|
|
||||||
|
set varspaces [list] |
||||||
|
dict for {vname vdef} $o_variables { |
||||||
|
set vs [dict get $vdef varspace] |
||||||
|
if {$vs ni $varspaces} { |
||||||
|
lappend varspaces $vs |
||||||
|
} |
||||||
|
} |
||||||
|
if {$o_varspace ni $varspaces} { |
||||||
|
lappend varspaces $o_varspace |
||||||
|
} |
||||||
|
return $varspaces |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::check_interfaces {} { |
||||||
|
foreach ns [namespace children ::p] { |
||||||
|
set IID [namespace tail $ns] |
||||||
|
if {[string is digit $IID]} { |
||||||
|
foreach ref [array names ${ns}::_iface::o_usedby] { |
||||||
|
set OID [string range $ref 1 end] |
||||||
|
if {![namespace exists ::p::${OID}::_iface]} { |
||||||
|
puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" |
||||||
|
} else { |
||||||
|
puts -nonewline stdout . |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#if {![info exists ::p::${OID}::(self)]} { |
||||||
|
# puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" |
||||||
|
#} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
puts -nonewline stdout "\r\n" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#from: http://wiki.tcl.tk/8766 (Introspection on aliases) |
||||||
|
#usedby: metaface-1.1.6+ |
||||||
|
#required because aliases can be renamed. |
||||||
|
#A renamed alias will still return it's target with 'interp alias {} oldname' |
||||||
|
# - so given newname - we require which_alias to return the same info. |
||||||
|
proc ::pattern::which_alias {cmd} { |
||||||
|
uplevel 1 [list ::trace add execution $cmd enterstep ::error] |
||||||
|
catch {uplevel 1 $cmd} res |
||||||
|
uplevel 1 [list ::trace remove execution $cmd enterstep ::error] |
||||||
|
#puts stdout "which_alias $cmd returning '$res'" |
||||||
|
return $res |
||||||
|
} |
||||||
|
# [info args] like proc following an alias recursivly until it reaches |
||||||
|
# the proc it originates from or cannot determine it. |
||||||
|
# accounts for default parameters set by interp alias |
||||||
|
# |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::aliasargs {cmd} { |
||||||
|
set orig $cmd |
||||||
|
|
||||||
|
set defaultargs [list] |
||||||
|
|
||||||
|
# loop until error or return occurs |
||||||
|
while {1} { |
||||||
|
# is it a proc already? |
||||||
|
if {[string equal [info procs $cmd] $cmd]} { |
||||||
|
set result [info args $cmd] |
||||||
|
# strip off the interp set default args |
||||||
|
return [lrange $result [llength $defaultargs] end] |
||||||
|
} |
||||||
|
# is it a built in or extension command we can get no args for? |
||||||
|
if {![string equal [info commands $cmd] $cmd]} { |
||||||
|
error "\"$orig\" isn't a procedure" |
||||||
|
} |
||||||
|
|
||||||
|
# catch bogus cmd names |
||||||
|
if {[lsearch [interp aliases {}] $cmd]==-1} { |
||||||
|
if {[catch {::pattern::which_alias $cmd} alias]} { |
||||||
|
error "\"$orig\" isn't a procedure or alias or command" |
||||||
|
} |
||||||
|
#set cmd [lindex $alias 0] |
||||||
|
if {[llength $alias]>1} { |
||||||
|
set cmd [lindex $alias 0] |
||||||
|
set defaultargs [concat [lrange $alias 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $alias |
||||||
|
} |
||||||
|
} else { |
||||||
|
|
||||||
|
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { |
||||||
|
# check if it is aliased in from another interpreter |
||||||
|
if {[catch {interp target {} $cmd} msg]} { |
||||||
|
error "Cannot resolve \"$orig\", alias leads to another interpreter." |
||||||
|
} |
||||||
|
if {$msg != {} } { |
||||||
|
error "Not recursing into slave interpreter \"$msg\".\ |
||||||
|
\"$orig\" could not be resolved." |
||||||
|
} |
||||||
|
# check if defaults are set for the alias |
||||||
|
if {[llength $cmdargs]>1} { |
||||||
|
set cmd [lindex $cmdargs 0] |
||||||
|
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $cmdargs |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
proc ::pattern::aliasbody {cmd} { |
||||||
|
set orig $cmd |
||||||
|
|
||||||
|
set defaultargs [list] |
||||||
|
|
||||||
|
# loop until error or return occurs |
||||||
|
while {1} { |
||||||
|
# is it a proc already? |
||||||
|
if {[string equal [info procs $cmd] $cmd]} { |
||||||
|
set result [info body $cmd] |
||||||
|
# strip off the interp set default args |
||||||
|
return $result |
||||||
|
#return [lrange $result [llength $defaultargs] end] |
||||||
|
} |
||||||
|
# is it a built in or extension command we can get no args for? |
||||||
|
if {![string equal [info commands $cmd] $cmd]} { |
||||||
|
error "\"$orig\" isn't a procedure" |
||||||
|
} |
||||||
|
|
||||||
|
# catch bogus cmd names |
||||||
|
if {[lsearch [interp aliases {}] $cmd]==-1} { |
||||||
|
if {[catch {::pattern::which_alias $cmd} alias]} { |
||||||
|
error "\"$orig\" isn't a procedure or alias or command" |
||||||
|
} |
||||||
|
#set cmd [lindex $alias 0] |
||||||
|
if {[llength $alias]>1} { |
||||||
|
set cmd [lindex $alias 0] |
||||||
|
set defaultargs [concat [lrange $alias 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $alias |
||||||
|
} |
||||||
|
} else { |
||||||
|
|
||||||
|
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { |
||||||
|
# check if it is aliased in from another interpreter |
||||||
|
if {[catch {interp target {} $cmd} msg]} { |
||||||
|
error "Cannot resolve \"$orig\", alias leads to another interpreter." |
||||||
|
} |
||||||
|
if {$msg != {} } { |
||||||
|
error "Not recursing into slave interpreter \"$msg\".\ |
||||||
|
\"$orig\" could not be resolved." |
||||||
|
} |
||||||
|
# check if defaults are set for the alias |
||||||
|
if {[llength $cmdargs]>1} { |
||||||
|
set cmd [lindex $cmdargs 0] |
||||||
|
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $cmdargs |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::uniqueKey2 {} { |
||||||
|
#!todo - something else?? |
||||||
|
return [clock seconds]-[incr ::pattern::idCounter] |
||||||
|
} |
||||||
|
|
||||||
|
#used by patternlib package |
||||||
|
proc ::pattern::uniqueKey {} { |
||||||
|
return [incr ::pattern::idCounter] |
||||||
|
#uuid with tcllibc is about 30us compared with 2us |
||||||
|
# for large datasets, e.g about 100K inserts this would be pretty noticable! |
||||||
|
#!todo - uuid pool with background thread to repopulate when idle? |
||||||
|
#return [uuid::uuid generate] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#------------------------------------------------------------------------------------------------------------------------- |
||||||
|
|
||||||
|
proc ::pattern::test1 {} { |
||||||
|
set msg "OK" |
||||||
|
|
||||||
|
puts stderr "next line should say:'--- saystuff:$msg" |
||||||
|
::>pattern .. Create ::>thing |
||||||
|
|
||||||
|
::>thing .. PatternMethod saystuff args { |
||||||
|
puts stderr "--- saystuff: $args" |
||||||
|
} |
||||||
|
::>thing .. Create ::>jjj |
||||||
|
|
||||||
|
::>jjj . saystuff $msg |
||||||
|
::>jjj .. Destroy |
||||||
|
::>thing .. Destroy |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::test2 {} { |
||||||
|
set msg "OK" |
||||||
|
|
||||||
|
puts stderr "next line should say:'--- property 'stuff' value:$msg" |
||||||
|
::>pattern .. Create ::>thing |
||||||
|
|
||||||
|
::>thing .. PatternProperty stuff $msg |
||||||
|
|
||||||
|
::>thing .. Create ::>jjj |
||||||
|
|
||||||
|
puts stderr "--- property 'stuff' value:[::>jjj . stuff]" |
||||||
|
::>jjj .. Destroy |
||||||
|
::>thing .. Destroy |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::test3 {} { |
||||||
|
set msg "OK" |
||||||
|
|
||||||
|
puts stderr "next line should say:'--- property 'stuff' value:$msg" |
||||||
|
::>pattern .. Create ::>thing |
||||||
|
|
||||||
|
::>thing .. Property stuff $msg |
||||||
|
|
||||||
|
puts stderr "--- property 'stuff' value:[::>thing . stuff]" |
||||||
|
::>thing .. Destroy |
||||||
|
} |
||||||
|
|
||||||
|
#--------------------------------- |
||||||
|
#unknown/obsolete |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} |
||||||
|
if {0} { |
||||||
|
proc ::p::internals::new_interface {{usedbylist {}}} { |
||||||
|
set OID [incr ::p::ID] |
||||||
|
::p::internals::new_object ::p::ifaces::>$OID "" $OID |
||||||
|
puts "obsolete >> new_interface created object $OID" |
||||||
|
foreach usedby $usedbylist { |
||||||
|
set ::p::${OID}::_iface::o_usedby(i$usedby) 1 |
||||||
|
} |
||||||
|
set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) |
||||||
|
#NOTE - o_varspace is only the default varspace for when new methods/properties are added. |
||||||
|
# it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. |
||||||
|
|
||||||
|
set ::p::${OID}::_iface::o_constructor [list] |
||||||
|
set ::p::${OID}::_iface::o_variables [list] |
||||||
|
set ::p::${OID}::_iface::o_properties [dict create] |
||||||
|
set ::p::${OID}::_iface::o_methods [dict create] |
||||||
|
array set ::p::${OID}::_iface::o_definition [list] |
||||||
|
set ::p::${OID}::_iface::o_open 1 ;#open for extending |
||||||
|
return $OID |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#temporary way to get OID - assumes single 'this' invocant |
||||||
|
#!todo - make generic. |
||||||
|
proc ::pattern::get_oid {_ID_} { |
||||||
|
#puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" |
||||||
|
return [lindex [dict get $_ID_ i this] 0 0] |
||||||
|
|
||||||
|
#set invocants [dict get $_ID_ i] |
||||||
|
#set invocant_roles [dict keys $invocants] |
||||||
|
#set role_members [dict get $invocants this] |
||||||
|
##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. |
||||||
|
#set this_invocant [lindex [dict get $_ID_ i this] 0] ; |
||||||
|
#lassign $this_invocant OID this_info |
||||||
|
# |
||||||
|
#return $OID |
||||||
|
} |
||||||
|
|
||||||
|
#compile the uncompiled level1 interface |
||||||
|
#assert: no more than one uncompiled interface present at level1 |
||||||
|
proc ::p::meta::PatternCompile {self} { |
||||||
|
???? |
||||||
|
|
||||||
|
upvar #0 $self SELFMAP |
||||||
|
set ID [lindex $SELFMAP 0 0] |
||||||
|
|
||||||
|
set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces |
||||||
|
|
||||||
|
set iid -1 |
||||||
|
foreach i $patterns { |
||||||
|
if {[set ::p::${i}::_iface::o_open]} { |
||||||
|
set iid $i ;#found it |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$iid > -1} { |
||||||
|
#!todo |
||||||
|
|
||||||
|
::p::compile_interface $iid |
||||||
|
set ::p::${iid}::_iface::o_open 0 |
||||||
|
} else { |
||||||
|
#no uncompiled interface present at level 1. Do nothing. |
||||||
|
return |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::p::meta::Def {self} { |
||||||
|
error ::p::meta::Def |
||||||
|
|
||||||
|
upvar #0 $self SELFMAP |
||||||
|
set self_ID [lindex $SELFMAP 0 0] |
||||||
|
set IFID [lindex $SELFMAP 1 0 end] |
||||||
|
|
||||||
|
set maxc1 0 |
||||||
|
set maxc2 0 |
||||||
|
|
||||||
|
set arrName ::p::${IFID}:: |
||||||
|
|
||||||
|
upvar #0 $arrName state |
||||||
|
|
||||||
|
array set methods {} |
||||||
|
|
||||||
|
foreach nm [array names state] { |
||||||
|
if {[regexp {^m-1,name,(.+)} $nm _match mname]} { |
||||||
|
set methods($mname) [set state($nm)] |
||||||
|
|
||||||
|
if {[string length $mname] > $maxc1} { |
||||||
|
set maxc1 [string length $mname] |
||||||
|
} |
||||||
|
if {[string length [set state($nm)]] > $maxc2} { |
||||||
|
set maxc2 [string length [set state($nm)]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set bg1 [string repeat " " [expr {$maxc1 + 2}]] |
||||||
|
set bg2 [string repeat " " [expr {$maxc2 + 2}]] |
||||||
|
|
||||||
|
|
||||||
|
set r {} |
||||||
|
foreach nm [lsort -dictionary [array names methods]] { |
||||||
|
set arglist $state(m-1,args,$nm) |
||||||
|
append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,754 @@ |
|||||||
|
package provide patternpredator2 1.2.4 |
||||||
|
|
||||||
|
proc ::p::internals::jaws {OID _ID_ args} { |
||||||
|
#puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" |
||||||
|
#set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
yield |
||||||
|
set w 1 |
||||||
|
|
||||||
|
set stack [list] |
||||||
|
set wordcount [llength $args] |
||||||
|
set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first |
||||||
|
set unsupported 0 |
||||||
|
set operator "" |
||||||
|
set operator_prev "" ;#used only by argprotect to revert to previous operator |
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
#!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) |
||||||
|
#upvar #0 ::p::${OID}::_meta::map MAP |
||||||
|
set MAP [set ::p::${OID}::_meta::map] |
||||||
|
} else { |
||||||
|
# error "jaws - OID = 'null' ???" |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key |
||||||
|
} |
||||||
|
set invocantdata [dict get $MAP invocantdata] |
||||||
|
lassign $invocantdata OID alias default_method object_command wrapped |
||||||
|
|
||||||
|
set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code |
||||||
|
|
||||||
|
#don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w |
||||||
|
while {$w < $wordcount} { |
||||||
|
set word [lindex $args [expr {$w -1}]] |
||||||
|
#puts stdout "w:$w word:$word stack:$stack" |
||||||
|
|
||||||
|
if {$operator eq "argprotect"} { |
||||||
|
set operator $operator_prev |
||||||
|
lappend stack $word |
||||||
|
incr w |
||||||
|
} else { |
||||||
|
if {[llength $stack]} { |
||||||
|
if {$word in $terminals} { |
||||||
|
set reduction [list 0 $_ID_ {*}$stack ] |
||||||
|
#puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" |
||||||
|
|
||||||
|
|
||||||
|
set _ID_ [yield $reduction] |
||||||
|
set stack [list] |
||||||
|
#set OID [::pattern::get_oid $_ID_] |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! |
||||||
|
} else { |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] |
||||||
|
#puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" |
||||||
|
} |
||||||
|
|
||||||
|
#review - 2018. switched to _ID_ instead of MAP |
||||||
|
lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command |
||||||
|
#lassign [dict get $MAP invocantdata] OID alias default_method object_command |
||||||
|
|
||||||
|
|
||||||
|
#puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" |
||||||
|
set operator $word |
||||||
|
#don't incr w |
||||||
|
#incr w |
||||||
|
} else { |
||||||
|
if {$operator eq "argprotect"} { |
||||||
|
set operator $operator_prev |
||||||
|
set operator_prev "" |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
#only look for leading argprotect chacter (-) if we're not already in argprotect mode |
||||||
|
if {$word eq "--"} { |
||||||
|
set operator_prev $operator |
||||||
|
set operator "argprotect" |
||||||
|
#Don't add the plain argprotector to the stack |
||||||
|
} elseif {[string match "-*" $word]} { |
||||||
|
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) |
||||||
|
set operator_prev $operator |
||||||
|
set operator "argprotect" |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
lappend stack $word |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
incr w |
||||||
|
} |
||||||
|
} else { |
||||||
|
#no stack |
||||||
|
switch -- $word {.} { |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
#we know next word is a property or method of a pattern object |
||||||
|
incr w |
||||||
|
set nextword [lindex $args [expr {$w - 1}]] |
||||||
|
set command ::p::${OID}::$nextword |
||||||
|
set stack [list $command] ;#2018 j |
||||||
|
set operator . |
||||||
|
if {$w eq $wordcount} { |
||||||
|
set finished_args 1 |
||||||
|
} |
||||||
|
} else { |
||||||
|
# don't incr w |
||||||
|
#set nextword [lindex $args [expr {$w - 1}]] |
||||||
|
set command $object_command ;#taken from the MAP |
||||||
|
set stack [list "_exec_" $command] |
||||||
|
set operator . |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} {..} { |
||||||
|
incr w |
||||||
|
set nextword [lindex $args [expr {$w -1}]] |
||||||
|
set command ::p::-1::$nextword |
||||||
|
#lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. |
||||||
|
set stack [list $command] ;#faster, and intent is clearer than lappend. |
||||||
|
set operator .. |
||||||
|
if {$w eq $wordcount} { |
||||||
|
set finished_args 1 |
||||||
|
} |
||||||
|
} {,} { |
||||||
|
#puts stdout "Stackless comma!" |
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set command ::p::${OID}::$default_method |
||||||
|
} else { |
||||||
|
set command [list $default_method $object_command] |
||||||
|
#object_command in this instance presumably be a list and $default_method a list operation |
||||||
|
#e.g "lindex {A B C}" |
||||||
|
} |
||||||
|
#lappend stack $command |
||||||
|
set stack [list $command] |
||||||
|
set operator , |
||||||
|
} {--} { |
||||||
|
set operator_prev $operator |
||||||
|
set operator argprotect |
||||||
|
#no stack - |
||||||
|
} {!} { |
||||||
|
set command $object_command |
||||||
|
set stack [list "_exec_" $object_command] |
||||||
|
#puts stdout "!!!! !!!! $stack" |
||||||
|
set operator ! |
||||||
|
} default { |
||||||
|
if {$operator eq ""} { |
||||||
|
if {$OID ne "null"} { |
||||||
|
set command ::p::${OID}::$default_method |
||||||
|
} else { |
||||||
|
set command [list $default_method $object_command] |
||||||
|
} |
||||||
|
set stack [list $command] |
||||||
|
set operator , |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
#no stack - so we don't expect to be in argprotect mode already. |
||||||
|
if {[string match "-*" $word]} { |
||||||
|
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) |
||||||
|
set operator_prev $operator |
||||||
|
set operator "argprotect" |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
lappend stack $word |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
incr w |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} ;#end while |
||||||
|
|
||||||
|
#process final word outside of loop |
||||||
|
#assert $w == $wordcount |
||||||
|
#trailing operators or last argument |
||||||
|
if {!$finished_args} { |
||||||
|
set word [lindex $args [expr {$w -1}]] |
||||||
|
if {$operator eq "argprotect"} { |
||||||
|
set operator $operator_prev |
||||||
|
set operator_prev "" |
||||||
|
|
||||||
|
lappend stack $word |
||||||
|
incr w |
||||||
|
} else { |
||||||
|
|
||||||
|
|
||||||
|
switch -- $word {.} { |
||||||
|
if {![llength $stack]} { |
||||||
|
#set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] |
||||||
|
yieldto return [::p::internals::ref_to_object $_ID_] |
||||||
|
error "assert: never gets here" |
||||||
|
|
||||||
|
} else { |
||||||
|
#puts stdout "==== $stack" |
||||||
|
#assert - whenever _ID_ changed in this proc - we have updated the $OID variable |
||||||
|
yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] |
||||||
|
error "assert: never gets here" |
||||||
|
} |
||||||
|
set operator . |
||||||
|
|
||||||
|
} {..} { |
||||||
|
#trailing .. after chained call e.g >x . item 0 .. |
||||||
|
#puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" |
||||||
|
#set reduction [list 0 $_ID_ {*}$stack] |
||||||
|
yieldto return [yield [list 0 $_ID_ {*}$stack]] |
||||||
|
} {#} { |
||||||
|
set unsupported 1 |
||||||
|
} {,} { |
||||||
|
set unsupported 1 |
||||||
|
} {&} { |
||||||
|
set unsupported 1 |
||||||
|
} {@} { |
||||||
|
set unsupported 1 |
||||||
|
} {--} { |
||||||
|
|
||||||
|
#set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] |
||||||
|
#puts stdout " -> -> -> about to call yield $reduction <- <- <-" |
||||||
|
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] |
||||||
|
#set OID [::pattern::get_oid $_ID_] |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! |
||||||
|
} else { |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] |
||||||
|
} |
||||||
|
yieldto return $MAP |
||||||
|
} {!} { |
||||||
|
#error "untested branch" |
||||||
|
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] |
||||||
|
#set OID [::pattern::get_oid $_ID_] |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! |
||||||
|
} else { |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] |
||||||
|
} |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_command object_command |
||||||
|
set command $object_command |
||||||
|
set stack [list "_exec_" $command] |
||||||
|
set operator ! |
||||||
|
} default { |
||||||
|
if {$operator eq ""} { |
||||||
|
#error "untested branch" |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_command object_command |
||||||
|
#set command ::p::${OID}::item |
||||||
|
set command ::p::${OID}::$default_command |
||||||
|
lappend stack $command |
||||||
|
set operator , |
||||||
|
|
||||||
|
} |
||||||
|
#do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. |
||||||
|
lappend stack $word |
||||||
|
} |
||||||
|
if {$unsupported} { |
||||||
|
set unsupported 0 |
||||||
|
error "trailing '$word' not supported" |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#if {$operator eq ","} { |
||||||
|
# incr wordcount 2 |
||||||
|
# set stack [linsert $stack end-1 . item] |
||||||
|
#} |
||||||
|
incr w |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#final = 1 |
||||||
|
#puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" |
||||||
|
|
||||||
|
return [list 1 $_ID_ {*}$stack] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#trailing. directly after object |
||||||
|
proc ::p::internals::ref_to_object {_ID_} { |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
||||||
|
upvar #0 ::p::${OID}::_meta::map MAP |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_method object_command |
||||||
|
set refname ::p::${OID}::_ref::__OBJECT |
||||||
|
|
||||||
|
array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] |
||||||
|
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
#puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" |
||||||
|
trace add variable $refname {read} $traceCmd |
||||||
|
} |
||||||
|
set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] |
||||||
|
if {[list {array} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
trace add variable $refname {array} $traceCmd |
||||||
|
} |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] |
||||||
|
if {[list {write} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
trace add variable $refname {write} $traceCmd |
||||||
|
} |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] |
||||||
|
if {[list {unset} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
trace add variable $refname {unset} $traceCmd |
||||||
|
} |
||||||
|
return $refname |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { |
||||||
|
#if {[lindex $fullstack 0] eq "_exec_"} { |
||||||
|
# #strip it. This instruction isn't relevant for a reference. |
||||||
|
# set commandstack [lrange $fullstack 1 end] |
||||||
|
#} else { |
||||||
|
# set commandstack $fullstack |
||||||
|
#} |
||||||
|
#set argstack [lassign $commandstack command] |
||||||
|
#set field [string map {> __OBJECT_} [namespace tail $command]] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
set reftail [namespace tail $refname] |
||||||
|
set argstack [lassign [split $reftail +] field] |
||||||
|
set field [string map {> __OBJECT_} [namespace tail $command]] |
||||||
|
|
||||||
|
#puts stderr "refname:'$refname' command: $command field:$field" |
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
upvar #0 ::p::${OID}::_meta::map MAP |
||||||
|
} else { |
||||||
|
#set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] |
||||||
|
} |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_method object_command |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
interp alias {} $refname {} $command $_ID_ {*}$argstack |
||||||
|
} else { |
||||||
|
interp alias {} $refname {} $command {*}$argstack |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#set iflist [lindex $map 1 0] |
||||||
|
set iflist [dict get $MAP interfaces level0] |
||||||
|
#set iflist [dict get $MAP interfaces level0] |
||||||
|
set field_is_property_like 0 |
||||||
|
foreach IFID [lreverse $iflist] { |
||||||
|
#tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. |
||||||
|
if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { |
||||||
|
set field_is_property_like 1 |
||||||
|
#There is a setter or getter (but not necessarily an entry in the o_properties dict) |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#whether field is a property or a method - remove any commandrefMisuse_TraceHandler |
||||||
|
foreach tinfo [trace info variable $refname] { |
||||||
|
#puts "-->removing traces on $refname: $tinfo" |
||||||
|
if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { |
||||||
|
trace remove variable $refname {*}$tinfo |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$field_is_property_like} { |
||||||
|
#property reference |
||||||
|
|
||||||
|
|
||||||
|
set this_invocantdata [lindex [dict get $_ID_ i this] 0] |
||||||
|
lassign $this_invocantdata OID _alias _defaultmethod object_command |
||||||
|
#get fully qualified varspace |
||||||
|
|
||||||
|
# |
||||||
|
set propdict [$object_command .. GetPropertyInfo $field] |
||||||
|
if {[dict exist $propdict $field]} { |
||||||
|
set field_is_a_property 1 |
||||||
|
set propinfo [dict get $propdict $field] |
||||||
|
set varspace [dict get $propinfo varspace] |
||||||
|
if {$varspace eq ""} { |
||||||
|
set full_varspace ::p::${OID} |
||||||
|
} else { |
||||||
|
if {[::string match "::*" $varspace]} { |
||||||
|
set full_varspace $varspace |
||||||
|
} else { |
||||||
|
set full_varspace ::p::${OID}::$varspace |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
set field_is_a_property 0 |
||||||
|
#no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property |
||||||
|
#this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) |
||||||
|
set full_varspace ::p::${OID} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) |
||||||
|
set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] |
||||||
|
if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { |
||||||
|
trace add variable ${full_varspace}::o_${field} {write} $Hndlr |
||||||
|
} |
||||||
|
set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] |
||||||
|
if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { |
||||||
|
trace add variable ${full_varspace}::o_${field} {unset} $Hndlr |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#supply all data in easy-access form so that propref_trace_read is not doing any extra work. |
||||||
|
set get_cmd ::p::${OID}::(GET)$field |
||||||
|
set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] |
||||||
|
|
||||||
|
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
set fieldvarname ${full_varspace}::o_${field} |
||||||
|
|
||||||
|
|
||||||
|
#synch the refvar with the real var if it exists |
||||||
|
#catch {set $refname [$refname]} |
||||||
|
if {[array exists $fieldvarname]} { |
||||||
|
if {![llength $argstack]} { |
||||||
|
#unindexed reference |
||||||
|
array set $refname [array get $fieldvarname] |
||||||
|
#upvar $fieldvarname $refname |
||||||
|
} else { |
||||||
|
set s0 [lindex $argstack 0] |
||||||
|
#refs to nonexistant array members common? (catch vs 'info exists') |
||||||
|
if {[info exists ${fieldvarname}($s0)]} { |
||||||
|
set $refname [set ${fieldvarname}($s0)] |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
#refs to uninitialised props actually should be *very* common. |
||||||
|
#If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. |
||||||
|
#Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. |
||||||
|
|
||||||
|
#set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! |
||||||
|
|
||||||
|
#puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" |
||||||
|
|
||||||
|
|
||||||
|
if {![llength $argstack]} { |
||||||
|
#catch {set $refname [set ::p::${OID}::o_$field]} |
||||||
|
if {[info exists $fieldvarname]} { |
||||||
|
set $refname [set $fieldvarname] |
||||||
|
#upvar $fieldvarname $refname |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {[llength $argstack] == 1} { |
||||||
|
#catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} |
||||||
|
if {[info exists $fieldvarname]} { |
||||||
|
set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} |
||||||
|
if {[info exists $fieldvarname]} { |
||||||
|
set $refname [lindex [set $fieldvarname] $argstack] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#! what if someone has put a trace on ::errorInfo?? |
||||||
|
#set ::errorInfo $errorInfo_prev |
||||||
|
} |
||||||
|
trace add variable $refname {read} $traceCmd |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] |
||||||
|
trace add variable $refname {write} $traceCmd |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] |
||||||
|
trace add variable $refname {unset} $traceCmd |
||||||
|
|
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] |
||||||
|
# puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" |
||||||
|
trace add variable $refname {array} $traceCmd |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#puts "$refname ====> adding refMisuse_traceHandler $alias $field" |
||||||
|
#matching variable in order to detect attempted use as property and throw error |
||||||
|
|
||||||
|
#2018 |
||||||
|
#Note that we are adding a trace on a variable (the refname) which does not exist. |
||||||
|
#this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) |
||||||
|
#we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added |
||||||
|
##array set $refname {} ;#empty array |
||||||
|
# - the empty array would mean a slightly better error message when misusing a command ref as an array |
||||||
|
#but this seems like a code complication for little benefit |
||||||
|
#review |
||||||
|
|
||||||
|
trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#trailing. after command/property |
||||||
|
proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { |
||||||
|
if {[lindex $fullstack 0] eq "_exec_"} { |
||||||
|
#strip it. This instruction isn't relevant for a reference. |
||||||
|
set commandstack [lrange $fullstack 1 end] |
||||||
|
} else { |
||||||
|
set commandstack $fullstack |
||||||
|
} |
||||||
|
set argstack [lassign $commandstack command] |
||||||
|
set field [string map {> __OBJECT_} [namespace tail $command]] |
||||||
|
|
||||||
|
|
||||||
|
#!todo? |
||||||
|
# - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. |
||||||
|
# - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. |
||||||
|
|
||||||
|
|
||||||
|
#references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. |
||||||
|
# - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. |
||||||
|
|
||||||
|
|
||||||
|
set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] |
||||||
|
|
||||||
|
if {[llength [info commands $refname]]} { |
||||||
|
#todo - review - what if the field changed to/from a property/method? |
||||||
|
#probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs |
||||||
|
return $refname |
||||||
|
} |
||||||
|
::p::internals::create_or_update_reference $OID $_ID_ $refname $command |
||||||
|
return $refname |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
namespace eval pp { |
||||||
|
variable operators [list .. . -- - & @ # , !] |
||||||
|
variable operators_notin_args "" |
||||||
|
foreach op $operators { |
||||||
|
append operators_notin_args "({$op} ni \$args) && " |
||||||
|
} |
||||||
|
set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands |
||||||
|
#set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} |
||||||
|
} |
||||||
|
interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. |
||||||
|
#each map is a 2 element list of lists. |
||||||
|
# form: {$commandinfo $interfaceinfo} |
||||||
|
# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} |
||||||
|
|
||||||
|
#2018 |
||||||
|
#each map is a dict. |
||||||
|
#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} |
||||||
|
|
||||||
|
|
||||||
|
#OID = Object ID (integer for now - could in future be a uuid) |
||||||
|
proc ::p::predator2 {_ID_ args} { |
||||||
|
#puts stderr "predator2: _ID_:'$_ID_' args:'$args'" |
||||||
|
#set invocants [dict get $_ID_ i] |
||||||
|
#set invocant_roles [dict keys $invocants] |
||||||
|
|
||||||
|
#For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. |
||||||
|
#set this_role_members [dict get $invocants this] |
||||||
|
#set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. |
||||||
|
#lassign $this_invocant this_OID this_info_dict |
||||||
|
|
||||||
|
set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
|
||||||
|
set cheat 1 ;# |
||||||
|
#------- |
||||||
|
#Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) |
||||||
|
#(it should be functionally equivalent to remove this shortcut block) |
||||||
|
if {$cheat} { |
||||||
|
if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { |
||||||
|
|
||||||
|
set remaining_args [lassign $args dot method_or_prop] |
||||||
|
|
||||||
|
#how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? |
||||||
|
set command ::p::${this_OID}::$method_or_prop |
||||||
|
#REVIEW! |
||||||
|
#e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') |
||||||
|
#if {[llength $command] > 1} { |
||||||
|
# error "methods with spaces not included in test suites - todo fix!" |
||||||
|
#} |
||||||
|
#Dont use {*}$command - (so we can support methods with spaces) |
||||||
|
#if {![llength [info commands $command]]} {} |
||||||
|
if {[namespace which $command] eq ""} { |
||||||
|
if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { |
||||||
|
#lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces |
||||||
|
set command ::p::${this_OID}::(UNKNOWN) |
||||||
|
#tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
} else { |
||||||
|
return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" |
||||||
|
} |
||||||
|
} else { |
||||||
|
#tailcall {*}$command $_ID_ {*}$remaining_args |
||||||
|
tailcall $command $_ID_ {*}$remaining_args |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
#------------ |
||||||
|
|
||||||
|
|
||||||
|
if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { |
||||||
|
return $_ID_ |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#puts stderr "this_info_dict: $this_info_dict" |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
if {![llength $args]} { |
||||||
|
#should return some sort of public info.. i.e probably not the ID which is an implementation detail |
||||||
|
#return cmd |
||||||
|
return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID |
||||||
|
|
||||||
|
#return a dict keyed on object command name - (suitable as use for a .. Create 'target') |
||||||
|
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped |
||||||
|
#return [list $object_command [list -id $this_OID ]] |
||||||
|
} elseif {[llength $args] == 1} { |
||||||
|
#short-circuit the single index case for speed. |
||||||
|
if {[lindex $args 0] ni {.. . -- - & @ # , !}} { |
||||||
|
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method |
||||||
|
lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method |
||||||
|
|
||||||
|
tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] |
||||||
|
} elseif {[lindex $args 0] eq {--}} { |
||||||
|
|
||||||
|
#!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. |
||||||
|
# - combined with using UUIDs for $OID, and a secured/removed metaface on the object |
||||||
|
# - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) |
||||||
|
# - this could effectively hide the object's namespaces,vars etc from the caller (?) |
||||||
|
return [set ::p::${this_OID}::_meta::map] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) |
||||||
|
#incr c |
||||||
|
#set reduce ::p::reducer${this_OID}_$c |
||||||
|
set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] |
||||||
|
#puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" |
||||||
|
coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args |
||||||
|
|
||||||
|
|
||||||
|
set current_ID_ $_ID_ |
||||||
|
|
||||||
|
set final 0 |
||||||
|
set result "" |
||||||
|
while {$final == 0} { |
||||||
|
#the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) |
||||||
|
set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] |
||||||
|
#puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" |
||||||
|
#if {[string match *Destroy $command]} { |
||||||
|
# puts stdout " calling Destroy reduction_args:'$reduction_args'" |
||||||
|
#} |
||||||
|
if {$final == 1} { |
||||||
|
|
||||||
|
if {[llength $command] == 1} { |
||||||
|
if {$command eq "_exec_"} { |
||||||
|
tailcall {*}$reduction_args |
||||||
|
} |
||||||
|
if {[llength [info commands $command]]} { |
||||||
|
tailcall {*}$command $current_ID_ {*}$reduction_args |
||||||
|
} |
||||||
|
set cmdname [namespace tail $command] |
||||||
|
set this_OID [lindex [dict get $current_ID_ i this] 0 0] |
||||||
|
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { |
||||||
|
lset command 0 ::p::${this_OID}::(UNKNOWN) |
||||||
|
tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
} else { |
||||||
|
return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#e.g lindex {a b c} |
||||||
|
tailcall {*}$command {*}$reduction_args |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} else { |
||||||
|
if {[lindex $command 0] eq "_exec_"} { |
||||||
|
set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] |
||||||
|
|
||||||
|
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] |
||||||
|
} else { |
||||||
|
if {[llength $command] == 1} { |
||||||
|
if {![llength [info commands $command]]} { |
||||||
|
set cmdname [namespace tail $command] |
||||||
|
set this_OID [lindex [dict get $current_ID_ i this] 0 0] |
||||||
|
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { |
||||||
|
|
||||||
|
lset command 0 ::p::${this_OID}::(UNKNOWN) |
||||||
|
set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
} else { |
||||||
|
return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" |
||||||
|
} |
||||||
|
} else { |
||||||
|
#set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] |
||||||
|
set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] |
||||||
|
|
||||||
|
} |
||||||
|
} else { |
||||||
|
set result [uplevel 1 [list {*}$command {*}$reduction_args]] |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength [info commands $result]]} { |
||||||
|
if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { |
||||||
|
#looks like a pattern command |
||||||
|
set current_ID_ [$result .. INVOCANTDATA] |
||||||
|
|
||||||
|
|
||||||
|
#todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA |
||||||
|
#if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { |
||||||
|
# set current_ID_ $result_invocantdata |
||||||
|
#} else { |
||||||
|
# return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" |
||||||
|
#} |
||||||
|
} else { |
||||||
|
#non-pattern command |
||||||
|
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] |
||||||
|
} |
||||||
|
} else { |
||||||
|
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] |
||||||
|
#!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
error "Assert: Shouldn't get here (end of ::p::predator2)" |
||||||
|
#return $result |
||||||
|
} |
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,290 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::aliascore 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin punkshell_module_punk::aliascore 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {punkshell command aliases}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::aliascore] |
||||||
|
#[keywords module alias] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::aliascore |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::aliascore |
||||||
|
#[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] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::aliascore::class { |
||||||
|
# #*** !doctools |
||||||
|
# #[subsection {Namespace punk::aliascore::class}] |
||||||
|
# #[para] class definitions |
||||||
|
# if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||||
|
# #*** !doctools |
||||||
|
# #[list_begin enumerated] |
||||||
|
# |
||||||
|
# # oo::class create interface_sample1 { |
||||||
|
# # #*** !doctools |
||||||
|
# # #[enum] CLASS [class interface_sample1] |
||||||
|
# # #[list_begin definitions] |
||||||
|
# |
||||||
|
# # method test {arg1} { |
||||||
|
# # #*** !doctools |
||||||
|
# # #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# # #[para] test method |
||||||
|
# # puts "test: $arg1" |
||||||
|
# # } |
||||||
|
# |
||||||
|
# # #*** !doctools |
||||||
|
# # #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# # } |
||||||
|
# |
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {--- end class enumeration ---}] |
||||||
|
# } |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::aliascore { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
variable aliases |
||||||
|
#use absolute ns ie must be prefixed with :: |
||||||
|
#single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased |
||||||
|
|
||||||
|
#functions must be in export list of their source namespace |
||||||
|
set aliases [tcl::dict::create\ |
||||||
|
val ::punk::pipe::val\ |
||||||
|
aliases ::punk::lib::aliases\ |
||||||
|
alias ::punk::lib::alias\ |
||||||
|
tstr ::punk::lib::tstr\ |
||||||
|
list_as_lines ::punk::lib::list_as_lines\ |
||||||
|
lines_as_list ::punk::lib::lines_as_list\ |
||||||
|
linelist ::punk::lib::linelist\ |
||||||
|
linesort ::punk::lib::linesort\ |
||||||
|
pdict ::punk::lib::pdict\ |
||||||
|
plist {::punk::lib::pdict -roottype list}\ |
||||||
|
showlist {::punk::lib::showdict -roottype list}\ |
||||||
|
rehash ::punk::rehash\ |
||||||
|
showdict ::punk::lib::showdict\ |
||||||
|
ansistrip ::punk::ansi::ansistrip\ |
||||||
|
stripansi ::punk::ansi::ansistrip\ |
||||||
|
ansiwrap ::punk::ansi::ansiwrap\ |
||||||
|
colour ::punk::console::colour\ |
||||||
|
ansi ::punk::console::ansi\ |
||||||
|
color ::punk::console::colour\ |
||||||
|
a? ::punk::console::code_a?\ |
||||||
|
A? {::punk::console::code_a? forcecolor}\ |
||||||
|
a+ ::punk::console::code_a+\ |
||||||
|
A+ {::punk::console::code_a+ forcecolour}\ |
||||||
|
a ::punk::console::code_a\ |
||||||
|
A {::punk::console::code_a forcecolour}\ |
||||||
|
smcup ::punk::console::enable_alt_screen\ |
||||||
|
rmcup ::punk::console::disable_alt_screen\ |
||||||
|
] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::aliascore}] |
||||||
|
#[para] Core API functions for punk::aliascore |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#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" |
||||||
|
#} |
||||||
|
|
||||||
|
#todo - options as to whether we should raise an error if collisions found, undo aliases etc? |
||||||
|
proc init {args} { |
||||||
|
set defaults {-force 0} |
||||||
|
set opts [dict merge $defaults $args] |
||||||
|
set opt_force [dict get $opts -force] |
||||||
|
|
||||||
|
#we never override existing aliases to ::repl::interp* even if -force = 1 |
||||||
|
#(these are our safebase aliases) |
||||||
|
set ignore_pattern "::repl::interp*" |
||||||
|
set ignore_aliases [list] |
||||||
|
|
||||||
|
variable aliases |
||||||
|
set existing [list] |
||||||
|
set conflicts [list] |
||||||
|
foreach {a cmd} $aliases { |
||||||
|
if {[tcl::info::commands ::$a] ne ""} { |
||||||
|
lappend existing $a |
||||||
|
set existing_alias [interp alias "" $a] |
||||||
|
if {$existing_alias ne ""} { |
||||||
|
set existing_target $existing_alias |
||||||
|
if {[string match $ignore_pattern $existing_target]} { |
||||||
|
#don't consider it a conflict - will use ignore_aliases to exclude it below |
||||||
|
lappend ignore_aliases $a |
||||||
|
continue |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {[catch {tcl::namespace::origin $a} existing_command]} { |
||||||
|
set existing_command "" |
||||||
|
} |
||||||
|
set existing_target $existing_command |
||||||
|
} |
||||||
|
|
||||||
|
if {$existing_target ne $cmd} { |
||||||
|
#command exists in global ns but doesn't match our defined aliases/imports |
||||||
|
lappend conflicts $a |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {!$opt_force && [llength $conflicts]} { |
||||||
|
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" |
||||||
|
} |
||||||
|
|
||||||
|
set tempns ::temp_[info cmdcount] ;#temp ns for renames |
||||||
|
dict for {a cmd} $aliases { |
||||||
|
#puts "aliascore $a -> $cmd" |
||||||
|
if {$a in $ignore_aliases} { |
||||||
|
continue |
||||||
|
} |
||||||
|
if {[llength $cmd] > 1} { |
||||||
|
interp alias {} $a {} {*}$cmd |
||||||
|
} else { |
||||||
|
if {[tcl::info::commands $cmd] ne ""} { |
||||||
|
#todo - ensure exported? noclobber? |
||||||
|
if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} { |
||||||
|
#puts stderr "importing $cmd" |
||||||
|
tcl::namespace::eval :: [list namespace import $cmd] |
||||||
|
} else { |
||||||
|
#target command name differs from exported name |
||||||
|
#e.g stripansi -> punk::ansi::ansistrip |
||||||
|
#import and rename |
||||||
|
#puts stderr "importing $cmd (with rename to ::$a)" |
||||||
|
tcl::namespace::eval $tempns [list namespace import $cmd] |
||||||
|
catch {rename ${tempns}::[namespace tail $cmd] ::$a} |
||||||
|
} |
||||||
|
} else { |
||||||
|
interp alias {} $a {} {*}$cmd |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
#tcl::namespace::delete $tempns |
||||||
|
return [dict create aliases [dict keys $aliases] unchanged $ignore_aliases changed $conflicts] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::aliascore ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#interp alias {} list_as_lines {} punk::lib::list_as_lines |
||||||
|
#interp alias {} lines_as_list {} punk::lib::lines_as_list |
||||||
|
#interp alias {} ansistrip {} punk::ansi::ansistrip ;#review |
||||||
|
#interp alias {} linelist {} punk::lib::linelist ;#critical for = assignment features |
||||||
|
#interp alias {} linesort {} punk::lib::linesort |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::aliascore::lib { |
||||||
|
namespace export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::aliascore::lib}] |
||||||
|
#[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 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::aliascore::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval punk::aliascore::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::aliascore::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::aliascore [namespace eval punk::aliascore { |
||||||
|
variable pkg punk::aliascore |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,487 @@ |
|||||||
|
|
||||||
|
tcl::namespace::eval punk::config { |
||||||
|
variable loaded |
||||||
|
variable startup ;#include env overrides |
||||||
|
variable running |
||||||
|
variable punk_env_vars |
||||||
|
variable other_env_vars |
||||||
|
|
||||||
|
variable vars |
||||||
|
|
||||||
|
namespace export {[a-z]*} |
||||||
|
|
||||||
|
#todo - XDG_DATA_HOME etc |
||||||
|
#https://specifications.freedesktop.org/basedir-spec/latest/ |
||||||
|
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ |
||||||
|
|
||||||
|
proc init {} { |
||||||
|
variable defaults |
||||||
|
variable startup |
||||||
|
variable running |
||||||
|
variable punk_env_vars |
||||||
|
variable punk_env_vars_config |
||||||
|
variable other_env_vars |
||||||
|
variable other_env_vars_config |
||||||
|
|
||||||
|
set exename "" |
||||||
|
catch { |
||||||
|
#catch for safe interps |
||||||
|
#safe base will return empty string, ordinary safe interp will raise error |
||||||
|
set exename [tcl::info::nameofexecutable] |
||||||
|
} |
||||||
|
if {$exename ne ""} { |
||||||
|
set exefolder [file dirname $exename] |
||||||
|
#default file logs to logs folder at same level as exe if writable, or empty string |
||||||
|
set log_folder [file normalize $exefolder/../logs] ;#~2ms |
||||||
|
#tcl::dict::set startup scriptlib $exefolder/scriptlib |
||||||
|
#tcl::dict::set startup apps $exefolder/../../punkapps |
||||||
|
|
||||||
|
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc |
||||||
|
set default_scriptlib $exefolder/scriptlib |
||||||
|
set default_apps $exefolder/../../punkapps |
||||||
|
if {[file isdirectory $log_folder] && [file writable $log_folder]} { |
||||||
|
#tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt |
||||||
|
#tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt |
||||||
|
set default_logfile_stdout $log_folder/repl-exec-stdout.txt |
||||||
|
set default_logfile_stderr $log_folder/repl-exec-stderr.txt |
||||||
|
} else { |
||||||
|
set default_logfile_stdout "" |
||||||
|
set default_logfile_stderr "" |
||||||
|
} |
||||||
|
} else { |
||||||
|
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island |
||||||
|
#review - todo? |
||||||
|
#tcl::dict::set startup scriptlib "" |
||||||
|
#tcl::dict::set startup apps "" |
||||||
|
set default_scriptlib "" |
||||||
|
set default_apps "" |
||||||
|
set default_logfile_stdout "" |
||||||
|
set default_logfile_stderr "" |
||||||
|
} |
||||||
|
|
||||||
|
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run |
||||||
|
|
||||||
|
#optional channel transforms on stdout/stderr. |
||||||
|
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands |
||||||
|
#If no distinction necessary - should use default_color_<chan> |
||||||
|
#The counterpart: default_color_<chan>_repl is a transform that is added and removed with each repl evaluation. |
||||||
|
#startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default |
||||||
|
set default_color_stdout brightwhite ;#stdout colour including background calls (after etc) |
||||||
|
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only |
||||||
|
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful. |
||||||
|
#set default_color_stderr "red bold" |
||||||
|
#set default_color_stderr "web-lightsalmon" |
||||||
|
set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive |
||||||
|
set default_color_stderr_repl "" ;#during repl call only |
||||||
|
|
||||||
|
set homedir "" |
||||||
|
if {[catch { |
||||||
|
#depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp |
||||||
|
#other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp |
||||||
|
set homedir [file home] |
||||||
|
} errM]} { |
||||||
|
#tcl 8.6 doesn't have file home.. try again |
||||||
|
if {[info exists ::env(HOME)]} { |
||||||
|
set homedir $::env(HOME) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# per user xdg vars |
||||||
|
# --- |
||||||
|
set default_xdg_config_home "" ;#config data - portable |
||||||
|
set default_xdg_data_home "" ;#data the user likely to want to be portable |
||||||
|
set default_xdg_cache_home "" ;#local cache |
||||||
|
set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home |
||||||
|
# --- |
||||||
|
set default_xdg_data_dirs "" ;#non-user specific |
||||||
|
#xdg_config_dirs ? |
||||||
|
#xdg_runtime_dir ? |
||||||
|
|
||||||
|
|
||||||
|
#review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent) |
||||||
|
#(safe interp generally won't have access to ::env either) |
||||||
|
#This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent. |
||||||
|
if {$homedir ne ""} { |
||||||
|
if {"windows" eq $::tcl_platform(platform)} { |
||||||
|
#as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them. |
||||||
|
#we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment) |
||||||
|
#using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do. |
||||||
|
if {[info exists ::env(APPDATA)]} { |
||||||
|
set default_xdg_config_home $::env(APPDATA) |
||||||
|
set default_xdg_data_home $::env(APPDATA) |
||||||
|
} |
||||||
|
|
||||||
|
#The xdg_cache_home should be kept local |
||||||
|
if {[info exists ::env(LOCALAPPDATA)]} { |
||||||
|
set default_xdg_cache_home $::env(LOCALAPPDATA) |
||||||
|
set default_xdg_state_home $::env(LOCALAPPDATA) |
||||||
|
} |
||||||
|
|
||||||
|
if {[info exists ::env(PROGRAMDATA)]} { |
||||||
|
#- equiv env(ALLUSERSPROFILE) ? |
||||||
|
set default_xdg_data_dirs $::env(PROGRAMDATA) |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html |
||||||
|
set default_xdg_config_home [file join $homedir .config] |
||||||
|
set default_xdg_data_home [file join $homedir .local share] |
||||||
|
set default_xdg_cache_home [file join $homedir .cache] |
||||||
|
set default_xdg_state_home [file join $homedir .local state] |
||||||
|
set default_xdg_data_dirs /usr/local/share |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set defaults [dict create\ |
||||||
|
apps $default_apps\ |
||||||
|
config ""\ |
||||||
|
configset ".punkshell"\ |
||||||
|
scriptlib $default_scriptlib\ |
||||||
|
color_stdout $default_color_stdout\ |
||||||
|
color_stdout_repl $default_color_stdout_repl\ |
||||||
|
color_stderr $default_color_stderr\ |
||||||
|
color_stderr_repl $default_color_stderr_repl\ |
||||||
|
logfile_stdout $default_logfile_stdout\ |
||||||
|
logfile_stderr $default_logfile_stderr\ |
||||||
|
logfile_active 0\ |
||||||
|
syslog_stdout "127.0.0.1:514"\ |
||||||
|
syslog_stderr "127.0.0.1:514"\ |
||||||
|
syslog_active 0\ |
||||||
|
auto_exec_mechanism exec\ |
||||||
|
auto_noexec 0\ |
||||||
|
xdg_config_home $default_xdg_config_home\ |
||||||
|
xdg_data_home $default_xdg_data_home\ |
||||||
|
xdg_cache_home $default_xdg_cache_home\ |
||||||
|
xdg_state_home $default_xdg_state_home\ |
||||||
|
xdg_data_dirs $default_xdg_data_dirs\ |
||||||
|
theme_posh_override ""\ |
||||||
|
posh_theme ""\ |
||||||
|
posh_themes_path ""\ |
||||||
|
] |
||||||
|
|
||||||
|
set startup $defaults |
||||||
|
#load values from saved config file - $xdg_config_home/punk/punk.config ? |
||||||
|
#typically we want env vars to override the stored config - as env vars conventionally used on some commandlines. |
||||||
|
#that's possibly ok for the PUNK_ vars |
||||||
|
#however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config? |
||||||
|
#making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence? |
||||||
|
#simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden |
||||||
|
#- requiring user to manually unset any unwanted env vars when launching? |
||||||
|
|
||||||
|
#we are likely to want the saved configs for subshells/decks to override them however. |
||||||
|
|
||||||
|
#todo - load/save config file |
||||||
|
|
||||||
|
#todo - define which configvars are settable in env |
||||||
|
#list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean) |
||||||
|
set punk_env_vars_config [dict create \ |
||||||
|
PUNK_APPS {type pathlist}\ |
||||||
|
PUNK_CONFIG {type string}\ |
||||||
|
PUNK_CONFIGSET {type string}\ |
||||||
|
PUNK_SCRIPTLIB {type string}\ |
||||||
|
PUNK_AUTO_EXEC_MECHANISM {type string}\ |
||||||
|
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\ |
||||||
|
PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\ |
||||||
|
PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\ |
||||||
|
PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\ |
||||||
|
PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ |
||||||
|
PUNK_LOGFILE_STDOUT {type string}\ |
||||||
|
PUNK_LOGFILE_STDERR {type string}\ |
||||||
|
PUNK_LOGFILE_ACTIVE {type string}\ |
||||||
|
PUNK_SYSLOG_STDOUT {type string}\ |
||||||
|
PUNK_SYSLOG_STDERR {type string}\ |
||||||
|
PUNK_SYSLOG_ACTIVE {type string}\ |
||||||
|
PUNK_THEME_POSH_OVERRIDE {type string}\ |
||||||
|
] |
||||||
|
set punk_env_vars [dict keys $punk_env_vars_config] |
||||||
|
|
||||||
|
#override with env vars if set |
||||||
|
foreach {evar varinfo} $punk_env_vars_config { |
||||||
|
if {[info exists ::env($evar)]} { |
||||||
|
set vartype [dict get $varinfo type] |
||||||
|
set f [set ::env($evar)] |
||||||
|
if {$f ne "default"} { |
||||||
|
#e.g PUNK_SCRIPTLIB -> scriptlib |
||||||
|
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] |
||||||
|
if {$vartype eq "pathlist"} { |
||||||
|
#colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system |
||||||
|
#Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief. |
||||||
|
#For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately. |
||||||
|
#some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched. |
||||||
|
#An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting |
||||||
|
# - but some programs have been known to split this value on colon anyway, which breaks things on windows. |
||||||
|
set paths [split $f $::tcl_platform(pathSeparator)] |
||||||
|
set final [list] |
||||||
|
#eliminate empty values (leading or trailing or extraneous separators) |
||||||
|
foreach p $paths { |
||||||
|
if {[tcl::string::trim $p] ne ""} { |
||||||
|
lappend final $p |
||||||
|
} |
||||||
|
} |
||||||
|
tcl::dict::set startup $varname $final |
||||||
|
} else { |
||||||
|
tcl::dict::set startup $varname $f |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# https://no-color.org |
||||||
|
#if {[info exists ::env(NO_COLOR)]} { |
||||||
|
# if {$::env(NO_COLOR) ne ""} { |
||||||
|
# set colour_disabled 1 |
||||||
|
# } |
||||||
|
#} |
||||||
|
set other_env_vars_config [dict create\ |
||||||
|
NO_COLOR {type string}\ |
||||||
|
XDG_CONFIG_HOME {type string}\ |
||||||
|
XDG_DATA_HOME {type string}\ |
||||||
|
XDG_CACHE_HOME {type string}\ |
||||||
|
XDG_STATE_HOME {type string}\ |
||||||
|
XDG_DATA_DIRS {type pathlist}\ |
||||||
|
POSH_THEME {type string}\ |
||||||
|
POSH_THEMES_PATH {type string}\ |
||||||
|
TCLLIBPATH {type string}\ |
||||||
|
] |
||||||
|
lassign [split [info tclversion] .] tclmajorv tclminorv |
||||||
|
#don't rely on lseq or punk::lib for now.. |
||||||
|
set relevant_minors [list] |
||||||
|
for {set i 0} {$i <= $tclminorv} {incr i} { |
||||||
|
lappend relevant_minors $i |
||||||
|
} |
||||||
|
foreach minor $relevant_minors { |
||||||
|
set vname TCL${tclmajorv}_${minor}_TM_PATH |
||||||
|
if {$minor eq $tclminorv || [info exists ::env($vname)]} { |
||||||
|
dict set other_env_vars_config $vname {type string} |
||||||
|
} |
||||||
|
} |
||||||
|
set other_env_vars [dict keys $other_env_vars_config] |
||||||
|
|
||||||
|
foreach {evar varinfo} $other_env_vars_config { |
||||||
|
if {[info exists ::env($evar)]} { |
||||||
|
set vartype [dict get $varinfo type] |
||||||
|
set f [set ::env($evar)] |
||||||
|
if {$f ne "default"} { |
||||||
|
set varname [tcl::string::tolower $evar] |
||||||
|
if {$vartype eq "pathlist"} { |
||||||
|
set paths [split $f $::tcl_platform(pathSeparator)] |
||||||
|
set final [list] |
||||||
|
#eliminate empty values (leading or trailing or extraneous separators) |
||||||
|
foreach p $paths { |
||||||
|
if {[tcl::string::trim $p] ne ""} { |
||||||
|
lappend final $p |
||||||
|
} |
||||||
|
} |
||||||
|
tcl::dict::set startup $varname $final |
||||||
|
} else { |
||||||
|
tcl::dict::set startup $varname $f |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#unset -nocomplain vars |
||||||
|
|
||||||
|
#todo |
||||||
|
set running [tcl::dict::create] |
||||||
|
set running [tcl::dict::merge $running $startup] |
||||||
|
} |
||||||
|
init |
||||||
|
|
||||||
|
#todo |
||||||
|
proc Apply {config} { |
||||||
|
puts stderr "punk::config::Apply partially implemented" |
||||||
|
set configname [string map {-config ""} $config] |
||||||
|
if {$configname in {startup running}} { |
||||||
|
upvar ::punk::config::$configname applyconfig |
||||||
|
|
||||||
|
if {[dict exists $applyconfig auto_noexec]} { |
||||||
|
set auto [dict get $applyconfig auto_noexec] |
||||||
|
if {![string is boolean -strict $auto]} { |
||||||
|
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" |
||||||
|
} |
||||||
|
if {$auto} { |
||||||
|
set ::auto_noexec 1 |
||||||
|
} else { |
||||||
|
#puts "auto_noexec false" |
||||||
|
unset -nocomplain ::auto_noexec |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
error "no config named '$config' found" |
||||||
|
} |
||||||
|
return "apply done" |
||||||
|
} |
||||||
|
Apply startup |
||||||
|
|
||||||
|
#todo - consider how to divide up settings, categories, 'devices', decks etc |
||||||
|
proc get_running_global {varname} { |
||||||
|
variable running |
||||||
|
if {[dict exists $running $varname]} { |
||||||
|
return [dict get $running $varname] |
||||||
|
} |
||||||
|
error "No such global configuration item '$varname' found in running config" |
||||||
|
} |
||||||
|
proc get_startup_global {varname} { |
||||||
|
variable startup |
||||||
|
if {[dict exists $startup $varname]} { |
||||||
|
return [dict get $startup $varname] |
||||||
|
} |
||||||
|
error "No such global configuration item '$varname' found in startup config" |
||||||
|
} |
||||||
|
|
||||||
|
proc get {whichconfig {globfor *}} { |
||||||
|
variable startup |
||||||
|
variable running |
||||||
|
switch -- $whichconfig { |
||||||
|
config - startup - startup-config - startup-configuration { |
||||||
|
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs |
||||||
|
set configdata $startup |
||||||
|
} |
||||||
|
running - running-config - running-configuration { |
||||||
|
set configdata $running |
||||||
|
} |
||||||
|
default { |
||||||
|
error "Unknown config name '$whichconfig' - try startup or running" |
||||||
|
} |
||||||
|
} |
||||||
|
if {$globfor eq "*"} { |
||||||
|
return $configdata |
||||||
|
} else { |
||||||
|
set keys [dict keys $configdata [string tolower $globfor]] |
||||||
|
set filtered [dict create] |
||||||
|
foreach k $keys { |
||||||
|
dict set filtered $k [dict get $configdata $k] |
||||||
|
} |
||||||
|
return $filtered |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc configure {args} { |
||||||
|
set argdef { |
||||||
|
@id -id ::punk::config::configure |
||||||
|
@cmd -name punk::config::configure -help\ |
||||||
|
"UNIMPLEMENTED" |
||||||
|
@values -min 1 -max 1 |
||||||
|
whichconfig -type string -choices {startup running stop} |
||||||
|
} |
||||||
|
set argd [punk::args::get_dict $argdef $args] |
||||||
|
return "unimplemented - $argd" |
||||||
|
} |
||||||
|
|
||||||
|
proc show {whichconfig {globfor *}} { |
||||||
|
#todo - tables for console |
||||||
|
set configdata [punk::config::get $whichconfig $globfor] |
||||||
|
return [punk::lib::showdict $configdata] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#e.g |
||||||
|
# copy running-config startup-config |
||||||
|
# copy startup-config test-config.cfg |
||||||
|
# copy backup-config.cfg running-config |
||||||
|
#review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite |
||||||
|
#This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration |
||||||
|
proc copy {args} { |
||||||
|
set argdef { |
||||||
|
@id -id ::punk::config::copy |
||||||
|
@cmd -name punk::config::copy -help\ |
||||||
|
"Copy a partial or full configuration from one config to another |
||||||
|
If a target config has additional settings, then the source config can be considered to be partial with regards to the target. |
||||||
|
" |
||||||
|
-type -default "" -choices {replace merge} -help\ |
||||||
|
"Defaults to merge when target is running-config |
||||||
|
Defaults to replace when source is running-config" |
||||||
|
@values -min 2 -max 2 |
||||||
|
fromconfig -help\ |
||||||
|
"running or startup or file name (not fully implemented)" |
||||||
|
toconfig -help\ |
||||||
|
"running or startup or file name (not fully implemented)" |
||||||
|
} |
||||||
|
set argd [punk::args::get_dict $argdef $args] |
||||||
|
set fromconfig [dict get $argd values fromconfig] |
||||||
|
set toconfig [dict get $argd values toconfig] |
||||||
|
set fromconfig [string map {-config ""} $fromconfig] |
||||||
|
set toconfig [string map {-config ""} $toconfig] |
||||||
|
|
||||||
|
set copytype [dict get $argd opts -type] |
||||||
|
|
||||||
|
|
||||||
|
#todo - warn & prompt if doing merge copy to startup |
||||||
|
switch -exact -- $fromconfig-$toconfig { |
||||||
|
running-startup { |
||||||
|
if {$copytype eq ""} { |
||||||
|
set copytype replace ;#full configuration |
||||||
|
} |
||||||
|
if {$copytype eq "replace"} { |
||||||
|
error "punk::config::copy error. full configuration copy from running to startup config not yet supported" |
||||||
|
} else { |
||||||
|
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" |
||||||
|
} |
||||||
|
} |
||||||
|
startup-running { |
||||||
|
#default type merge - even though it's not always what is desired |
||||||
|
if {$copytype eq ""} { |
||||||
|
set copytype merge ;#load in a partial configuration |
||||||
|
} |
||||||
|
|
||||||
|
#warn/prompt either way |
||||||
|
if {$copytype eq "replace"} { |
||||||
|
#some routers require use of a separate command for this branch. |
||||||
|
#presumably to ensure the user doesn't accidentally load partials onto a running system |
||||||
|
# |
||||||
|
error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" |
||||||
|
} else { |
||||||
|
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#todo - move to cli? |
||||||
|
::tcl::namespace::eval punk::config { |
||||||
|
#todo - something better - 'previous' rather than reverting to startup |
||||||
|
proc channelcolors {{onoff {}}} { |
||||||
|
variable running |
||||||
|
variable startup |
||||||
|
|
||||||
|
if {![string length $onoff]} { |
||||||
|
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
||||||
|
} else { |
||||||
|
if {![string is boolean $onoff]} { |
||||||
|
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" |
||||||
|
} |
||||||
|
if {$onoff} { |
||||||
|
dict set running color_stdout [dict get $startup color_stdout] |
||||||
|
dict set running color_stderr [dict get $startup color_stderr] |
||||||
|
} else { |
||||||
|
dict set running color_stdout "" |
||||||
|
dict set running color_stderr "" |
||||||
|
} |
||||||
|
} |
||||||
|
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
package provide punk::config [tcl::namespace::eval punk::config { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
|
||||||
|
}] |
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@ -1,3 +1,3 @@ |
|||||||
%Major.Minor.Level% |
%Major.Minor.Level% |
||||||
#First line must be a semantic version number |
#First line must be a tcl package version number |
||||||
#all other lines are ignored. |
#all other lines are ignored. |
||||||
|
|||||||
@ -0,0 +1,164 @@ |
|||||||
|
#punkapps app manager |
||||||
|
# deck cli |
||||||
|
|
||||||
|
namespace eval punk::mod::cli { |
||||||
|
namespace export help list run |
||||||
|
namespace ensemble create |
||||||
|
|
||||||
|
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown |
||||||
|
if 0 { |
||||||
|
proc _unknown {ns args} { |
||||||
|
puts stderr "punk::mod::cli::_unknown '$ns' '$args'" |
||||||
|
puts stderr "punk::mod::cli::help $args" |
||||||
|
puts stderr "arglen:[llength $args]" |
||||||
|
punk::mod::cli::help {*}$args |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#cli must have _init method - usually used to load commandsets lazily |
||||||
|
# |
||||||
|
variable initialised 0 |
||||||
|
proc _init {args} { |
||||||
|
variable initialised |
||||||
|
if {$initialised} { |
||||||
|
return |
||||||
|
} |
||||||
|
#... |
||||||
|
set initialised 1 |
||||||
|
} |
||||||
|
|
||||||
|
proc help {args} { |
||||||
|
set basehelp [punk::mix::base help {*}$args] |
||||||
|
#namespace export |
||||||
|
return $basehelp |
||||||
|
} |
||||||
|
proc getraw {appname} { |
||||||
|
upvar ::punk::config::running running_config |
||||||
|
set app_folders [dict get $running_config apps] |
||||||
|
#todo search each app folder |
||||||
|
set bases [::list] |
||||||
|
set versions [::list] |
||||||
|
set mains [::list] |
||||||
|
set appinfo [::list bases {} mains {} versions {}] |
||||||
|
|
||||||
|
foreach containerfolder $app_folders { |
||||||
|
lappend bases $containerfolder |
||||||
|
if {[file exists $containerfolder]} { |
||||||
|
if {[file exists $containerfolder/$appname/main.tcl]} { |
||||||
|
#exact match - only return info for the exact one specified |
||||||
|
set namematches $appname |
||||||
|
set parts [split $appname -] |
||||||
|
} else { |
||||||
|
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] |
||||||
|
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||||
|
} |
||||||
|
foreach nm $namematches { |
||||||
|
set mainfile $containerfolder/$nm/main.tcl |
||||||
|
set parts [split $nm -] |
||||||
|
if {[llength $parts] == 1} { |
||||||
|
set ver "" |
||||||
|
} else { |
||||||
|
set ver [lindex $parts end] |
||||||
|
} |
||||||
|
if {$ver ni $versions} { |
||||||
|
lappend versions $ver |
||||||
|
lappend mains $ver $mainfile |
||||||
|
} else { |
||||||
|
puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" |
||||||
|
} |
||||||
|
} |
||||||
|
dict set appinfo versions $versions |
||||||
|
#todo - natsort! |
||||||
|
set sorted_versions [lsort $versions] |
||||||
|
set latest [lindex $sorted_versions 0] |
||||||
|
if {$latest eq "" && [llength $sorted_versions] > 1} { |
||||||
|
set latest [lindex $sorted_versions 1 |
||||||
|
} |
||||||
|
dict set appinfo latest $latest |
||||||
|
|
||||||
|
dict set appinfo bases $bases |
||||||
|
dict set appinfo mains $mains |
||||||
|
return $appinfo |
||||||
|
} |
||||||
|
|
||||||
|
proc list {{glob *}} { |
||||||
|
upvar ::punk::config::running running_config |
||||||
|
set apps_folder [dict get $running_config apps] |
||||||
|
if {[file exists $apps_folder]} { |
||||||
|
if {[file exists $apps_folder/$glob]} { |
||||||
|
#tailcall source $apps_folder/$glob/main.tcl |
||||||
|
return $glob |
||||||
|
} |
||||||
|
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] |
||||||
|
if {[llength $apps] == 0} { |
||||||
|
if {[string first * $glob] <0 && [string first ? $glob] <0} { |
||||||
|
#no glob chars supplied - only launch if exact match for name part |
||||||
|
set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] |
||||||
|
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||||
|
if {[llength $namematches] > 0} { |
||||||
|
set latest [lindex $namematches end] |
||||||
|
lassign $latest nm ver |
||||||
|
#tailcall source $apps_folder/$latest/main.tcl |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return $apps |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#todo - way to launch as separate process |
||||||
|
# solo-opts only before appname - args following appname are passed to the app |
||||||
|
proc run {args} { |
||||||
|
set nameposn [lsearch -not $args -*] |
||||||
|
if {$nameposn < 0} { |
||||||
|
error "punkapp::run unable to determine application name" |
||||||
|
} |
||||||
|
set appname [lindex $args $nameposn] |
||||||
|
set controlargs [lrange $args 0 $nameposn-1] |
||||||
|
set appargs [lrange $args $nameposn+1 end] |
||||||
|
|
||||||
|
set appinfo [punk::mod::cli::getraw $appname] |
||||||
|
if {[llength [dict get $appinfo versions]]} { |
||||||
|
set ver [dict get $appinfo latest] |
||||||
|
puts stdout "info: $appinfo" |
||||||
|
set ::argc [llength $appargs] |
||||||
|
set ::argv $appargs |
||||||
|
source [dict get $appinfo mains $ver] |
||||||
|
if {"-hideconsole" in $controlargs} { |
||||||
|
puts stderr "attempting console hide" |
||||||
|
#todo - something better - a callback when window mapped? |
||||||
|
after 500 {::punkapp::hide_console} |
||||||
|
} |
||||||
|
return $appinfo |
||||||
|
} else { |
||||||
|
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
namespace eval punk::mod::cli { |
||||||
|
proc _cli {args} { |
||||||
|
#don't use tailcall - base uses info level to determine caller |
||||||
|
::punk::mix::base::_cli {*}$args |
||||||
|
} |
||||||
|
variable default_command help |
||||||
|
package require punk::mix::base |
||||||
|
package require punk::overlay |
||||||
|
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||||
|
} |
||||||
|
|
||||||
|
package provide punk::mod [namespace eval punk::mod { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
|
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,420 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::packagepreference 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[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 --}] |
||||||
|
#[require punk::packagepreference] |
||||||
|
#[keywords module package] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::packagepreference |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::packagepreference |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require commandstack |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
#[item] [package {commandstack}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::packagepreference::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::packagepreference::class}] |
||||||
|
#[para] class definitions |
||||||
|
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
#} |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::packagepreference { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
|
||||||
|
variable PUNKARGS |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::packagepreference}] |
||||||
|
#[para] Core API functions for punk::packagepreference |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
lappend PUNKARGS [list { |
||||||
|
@id -id ::punk::packagepreference::install |
||||||
|
@cmd -name ::punk::packagepreference::install -help\ |
||||||
|
"Install override for ::package builtin - for 'require' subcommand only." |
||||||
|
@values -min 0 -max 0 |
||||||
|
}] |
||||||
|
proc uninstall {} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun uninstall]] |
||||||
|
#[para]Return to the previous ::package implementation (This will be the builtin if no other override was present when install was called) |
||||||
|
|
||||||
|
commandstack::remove_rename {::package punk::packagepreference} |
||||||
|
} |
||||||
|
|
||||||
|
lappend PUNKARGS [list { |
||||||
|
@id -id ::punk::packagepreference::install |
||||||
|
@cmd -name ::punk::packagepreference::install -help\ |
||||||
|
"Install override for ::package builtin - for 'require' subcommand only." |
||||||
|
@values -min 0 -max 0 |
||||||
|
}] |
||||||
|
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](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" |
||||||
|
#[para] https://core.tcl-lang.org/tips/doc/trunk/tip/590.md |
||||||
|
#[para]It prevents some loading errors when multiple package versions are available to an interpreter and the latest version is only provided by a lowercased module (.tm file) |
||||||
|
#[para]A package provided by the standard pkgIndex.tcl mechanism might override a later-versioned package because it may support both upper and lowercased names. |
||||||
|
#[para]The overriding of ::package only looks at 'package require' calls and preferentially tries the lowercase version (if the package isn't already loaded with either upper or lowercase name) |
||||||
|
#[para]This comes at some slight cost for packages that are only available with uppercase letters in the name - but at minimal cost for recommended lowercase package names |
||||||
|
#[para]Return to the standard ::package builtin by calling punk::packagepreference::uninstall |
||||||
|
|
||||||
|
#todo - review/update commandstack package |
||||||
|
#modern module/lib names should preferably be lower case |
||||||
|
#see tip 590 - "Recommend lowercase Package names". Where non-lowercase are deprecated (but not removed even in Tcl9) |
||||||
|
#Mixed case causes problems esp on windows where we can't have Package.tm and package.tm as they aren't distinguishable. |
||||||
|
#We enforce package to try lowercase first - at some potentially significant speed penalty if the lib actually does use uppercase |
||||||
|
#(also just overloading the package builtin comes at a cost!) |
||||||
|
#Without the lowercase-first mechanism - a lower versioned package such as Tablelist provided by a pkgIndex.tcl may be loaded in precedence to a higher versioned tablelist provided by a .tm |
||||||
|
#As punk kits launched with dev first arg may use tcl::tm::paths coming from both the system and zipkits for example - this is a problem. |
||||||
|
#(or in any environment where multiple versions of Tcl libraries may be available) |
||||||
|
#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 |
||||||
|
#return to previous 'package' implementation with: punk::packagepreference::uninstall |
||||||
|
|
||||||
|
#uglier but faster than tcl::prefix::match in this instance |
||||||
|
#maintenance - check no prefixes of require are added to builtin package command |
||||||
|
switch -exact -- [lindex $args 0] { |
||||||
|
r - re - req - requi - requir - require { |
||||||
|
#puts "==>package $args" |
||||||
|
#puts "==>[info level 1]" |
||||||
|
#despite preference for lowercase - we need to handle packages that insist on providing as uppercase |
||||||
|
#(e.g we will still need to handle things like: package provide Tcl 8.6) |
||||||
|
#Where the package is already provided uppercase we shouldn't waste time deferring to lowercase |
||||||
|
set is_exact 0 |
||||||
|
if {[lindex $args 1] eq "-exact"} { |
||||||
|
set pkg [lindex $args 2] |
||||||
|
set vwant [lindex $args 3]-[lindex $args 3] |
||||||
|
set is_exact 1 |
||||||
|
} else { |
||||||
|
set pkg [lindex $args 1] |
||||||
|
set vwant [lrange $args 2 end] ;#rare - but version can be a list of options |
||||||
|
if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { |
||||||
|
#only one version - and it has a dash |
||||||
|
lassign [split [lindex $vwant 0] -] a b |
||||||
|
if {$a eq $b} { |
||||||
|
#string compare version nums (can contain dots and a|b) |
||||||
|
set is_exact 1 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} { |
||||||
|
#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] |
||||||
|
} |
||||||
|
|
||||||
|
if {!$is_exact && [llength $vwant] <= 1 } { |
||||||
|
#required version unspecified - or specified singularly |
||||||
|
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 |
||||||
|
#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 |
||||||
|
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" |
||||||
|
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. |
||||||
|
set lcpath_to_version [dict create] |
||||||
|
foreach av $available_versions { |
||||||
|
set scr [package ifneeded $pkg $av] |
||||||
|
#ifneeded script not always a valid tcl list |
||||||
|
if {![catch {llength $scr} scrlen]} { |
||||||
|
if {$scrlen == 3 && [lindex $scr 0] eq "load" && [string match -nocase [lindex $scr 2] $pkg]} { |
||||||
|
dict set lcpath_to_version [string tolower [lindex $scr 1]] $av |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[dict exists $lcpath_to_version $lcpath]} { |
||||||
|
set lversion [dict get $lcpath_to_version $lcpath] |
||||||
|
} else { |
||||||
|
#fallback to a best effort guess based on the path |
||||||
|
set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $path $pkg] |
||||||
|
} |
||||||
|
if {$lversion ne ""} { |
||||||
|
#name matches pkg |
||||||
|
#hack for known dll version mismatch |
||||||
|
if {[string tolower $pkg] eq "thread" && $lversion eq "30b3"} { |
||||||
|
set lversion 3.0b3 |
||||||
|
} |
||||||
|
if {[llength $vwant] == 1} { |
||||||
|
#todo - still check vsatisfies - report a conflict? review |
||||||
|
} |
||||||
|
return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
# --------------------------------------------------------------- |
||||||
|
set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg] |
||||||
|
|
||||||
|
if {[regexp {[A-Z]} $pkg]} { |
||||||
|
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation |
||||||
|
if {[catch {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} { |
||||||
|
return [$COMMANDSTACKNEXT require $pkg {*}$vwant] |
||||||
|
} else { |
||||||
|
return $v |
||||||
|
} |
||||||
|
} else { |
||||||
|
return [$COMMANDSTACKNEXT require $pkg {*}$vwant] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
return [$COMMANDSTACKNEXT {*}$args] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
}] |
||||||
|
if {[dict get $stackrecord implementation] ne ""} { |
||||||
|
set impl [dict get $stackrecord implementation] ;#use hardcoded name rather than slower (but more flexible) commandstack::get_next_command |
||||||
|
#puts stdout "punk::packagepreference renamed ::package to $impl" |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
puts stderr "punk::packagepreference failed to rename ::package" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
#puts stdout [info body ::package] |
||||||
|
} |
||||||
|
|
||||||
|
#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::packagepreference ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::packagepreference::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::packagepreference::lib}] |
||||||
|
#[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 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::packagepreference::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
tcl::namespace::eval punk::packagepreference::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::packagepreference::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
variable PUNKARGS |
||||||
|
|
||||||
|
lappend PUNKARGS [list { |
||||||
|
@id -id ::punk::packagepreference::system::slibpath_guess_pkgversion |
||||||
|
@cmd -name punk::packagepreference::system::slibpath_guess_pkgversion -help\ |
||||||
|
"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 |
||||||
|
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 |
||||||
|
complex ifneeded script. If the ifneeded script for a binary package is a |
||||||
|
straightforward 'load <path_to_binary> <pkgname>' - then that information |
||||||
|
should be used to determine the version by matching <path_to_binary> |
||||||
|
rather than this one. |
||||||
|
|
||||||
|
Takes a path to a shared lib (.so/.dll), and the name of its providing |
||||||
|
package, and return the version of the package if possible to determine |
||||||
|
from the path. |
||||||
|
The filename portion of the lib is often missing a version number or has |
||||||
|
a version number that has been shortened (e.g dots removed). |
||||||
|
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<int>) |
||||||
|
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 |
||||||
|
insensitive match of the prefix to $pkgname. |
||||||
|
" |
||||||
|
@values -min 1 |
||||||
|
libpath -help "Full path to shared library (.so,.dll etc)" |
||||||
|
pkgname -help "" |
||||||
|
}] |
||||||
|
proc slibpath_guess_pkgversion {libpath pkgname} { |
||||||
|
set root [file rootname [file tail $libpath]] |
||||||
|
set namelen [string length $pkgname] |
||||||
|
regexp {^(tcl(?:[0-9])+){0,1}(.*)} $root _match tclxx root ;#regexp will match anything - but only truncate leading tclXX.. |
||||||
|
set testv "" |
||||||
|
if {[string match -nocase $pkgname* $root]} { |
||||||
|
set testv [string range $root $namelen end] |
||||||
|
} elseif {[string match -nocase lib$pkgname* $root]} { |
||||||
|
set testv [string range $root $namelen+3 end] |
||||||
|
} |
||||||
|
if {[string first . $testv] > 0} { |
||||||
|
if {![catch [list package vcompare $testv $testv]]} { |
||||||
|
#testv has an inner dot and is understood by tcl as a valid version number |
||||||
|
return $testv |
||||||
|
} |
||||||
|
} |
||||||
|
#no valid dotted version found directly on dll or so filename |
||||||
|
set parent [file dirname $libpath] ;#parent folder is often some differentiator for platform or featureset (e.g win-x64) |
||||||
|
set grandparent [file dirname $parent] |
||||||
|
foreach path [list $parent $grandparent] { |
||||||
|
set segment [file tail $path] |
||||||
|
if {$segment eq "bin"} { |
||||||
|
continue |
||||||
|
} |
||||||
|
set testv "" |
||||||
|
if {[string match -nocase $pkgname* $segment]} { |
||||||
|
set testv [string range $segment $namelen end] |
||||||
|
} elseif {[string match -nocase critcl_$pkgname* $segment]} { |
||||||
|
set testv [string range $segment $namelen+7 end] |
||||||
|
} |
||||||
|
#we don't look for dot in parent/grandparent version - a bare integer here after the <pkgname> will be taken to be the version |
||||||
|
if {![catch [list package vcompare $testv $testv]]} { |
||||||
|
return $testv |
||||||
|
} |
||||||
|
} |
||||||
|
#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 |
||||||
|
return "" |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
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::packagepreference ::punk::packagepreference::system |
||||||
|
} |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { |
||||||
|
variable pkg punk::packagepreference |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,853 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# 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::pipe 1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::pipe 0 1.0] |
||||||
|
#[copyright "2025"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::pipe] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::pipe |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::pipe |
||||||
|
#[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] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::pipe::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::pipe::class}] |
||||||
|
#[para] class definitions |
||||||
|
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
#} |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
tcl::namespace::eval punk::pipe { |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::pipe}] |
||||||
|
#[para] Core API functions for punk::pipe |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#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" |
||||||
|
#} |
||||||
|
|
||||||
|
#https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ |
||||||
|
# |
||||||
|
#we can't provide a float comparison suitable for every situation, |
||||||
|
#but we should pick something reasonable, keep it stable, and document it. |
||||||
|
proc float_almost_equal {a b} { |
||||||
|
package require math::constants |
||||||
|
set diff [expr {abs($a - $b)}] |
||||||
|
if {$diff <= $::math::constants::eps} { |
||||||
|
return 1 |
||||||
|
} |
||||||
|
set A [expr {abs($a)}] |
||||||
|
set B [expr {abs($b)}] |
||||||
|
set largest [expr {($B > $A) ? $B : $A}] |
||||||
|
return [expr {$diff <= $largest * $::math::constants::eps}] |
||||||
|
} |
||||||
|
|
||||||
|
#debatable whether boolean_almost_equal is more surprising than helpful. |
||||||
|
#values from a calculation that are extremely close to zero but aren't false could also be surprising - especially if they compare equal numerically |
||||||
|
#perhaps a fuzzy-boolean is a step too far for a default - but it's inline with float-comparison for pattern-matching. |
||||||
|
#alternatively - use an even more complex classifier? (^&~) ? |
||||||
|
proc boolean_almost_equal {a b} { |
||||||
|
if {[string is double -strict $a]} { |
||||||
|
if {[float_almost_equal $a 0]} { |
||||||
|
set a 0 |
||||||
|
} |
||||||
|
} |
||||||
|
if {[string is double -strict $b]} { |
||||||
|
if {[float_almost_equal $b 0]} { |
||||||
|
set b 0 |
||||||
|
} |
||||||
|
} |
||||||
|
#must handle true,no etc. |
||||||
|
expr {($a && 1) == ($b && 1)} |
||||||
|
} |
||||||
|
|
||||||
|
#boolean could be tr, true, y, ye, yes,Yes, 1 , 0 etc. |
||||||
|
proc boolean_equal {a b} { |
||||||
|
#equivalenttly xnor: expr {!(($a && 1) ^ ($b && 1))} ;# less clear and no discernable timing benefit. |
||||||
|
expr {($a && 1) == ($b && 1)} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc val [list [list v [lreplace x 0 0]]] {return $v} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::pipe ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::pipe::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::pipe::lib}] |
||||||
|
#[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 |
||||||
|
#} |
||||||
|
|
||||||
|
#map rhs to names suitable to use in pipemcd proc name (whitespace mapping) |
||||||
|
# (for .= and = pipecmds) |
||||||
|
proc pipecmd_namemapping {rhs} { |
||||||
|
#used to build a command from a pattern which could contain :: - we need to map it to keep it a single command in the desired namespace. |
||||||
|
#glob chars will prevent us using simple test {[info commands $cmd] eq ""} to test existence |
||||||
|
#we could use the test {$cmd in [info commands]} - but mapping away globchars is more robust, allowing the simpler test |
||||||
|
#set rhs [string trim $rhs];#ignore all leading & trailing whitespace |
||||||
|
set rhs [string trimleft $rhs] |
||||||
|
#--- |
||||||
|
#REVIEW! |
||||||
|
#set rhs [regsub -all {\s{1,}} $rhs {<sp>}] ;#collapse all internal whitespace to a single <sp> token |
||||||
|
#This stops us matching {/@**@x x} vs {/@**@x x} |
||||||
|
#--- |
||||||
|
|
||||||
|
set rhs [tcl::string::map {: <c> ? <q> * <star> [ <lb> ] <rb> \\ <bsl> {"} <dq> " " <sp>} $rhs] |
||||||
|
#review - we don't expect other command-incompatible chars such as colon? |
||||||
|
return $rhs |
||||||
|
} |
||||||
|
|
||||||
|
# relatively slow on even small sized scripts |
||||||
|
#proc arg_is_script_shaped2 {arg} { |
||||||
|
# set re {^(\s|;|\n)$} |
||||||
|
# set chars [split $arg ""] |
||||||
|
# if {[lsearch -regex $chars $re] >=0} { |
||||||
|
# return 1 |
||||||
|
# } else { |
||||||
|
# return 0 |
||||||
|
# } |
||||||
|
#} |
||||||
|
|
||||||
|
#exclude quoted whitespace |
||||||
|
proc arg_is_script_shaped {arg} { |
||||||
|
if {[tcl::string::first \n $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} elseif {[tcl::string::first ";" $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} elseif {[tcl::string::first " " $arg] >= 0 || [tcl::string::first \t $arg] >= 0} { |
||||||
|
lassign [_rhs_tail_split $arg] _ part2 ;#will have part2 if unquoted whitespace found |
||||||
|
return [expr {$part2 ne ""}] |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#split top level of patterns only. |
||||||
|
proc _split_patterns_memoized {varspecs} { |
||||||
|
set name_mapped [pipecmd_namemapping $varspecs] |
||||||
|
set cmdname ::punk::pipecmds::split_patterns::_$name_mapped |
||||||
|
if {[info commands $cmdname] ne ""} { |
||||||
|
return [$cmdname] |
||||||
|
} |
||||||
|
set result [_split_patterns $varspecs] |
||||||
|
proc $cmdname {} [list return $result] |
||||||
|
#debug.punk.pipe.compile {proc $cmdname} 4 |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#note - empty data after trailing , is ignored. (comma as very last character) |
||||||
|
# - fix by documentation only. double up trailing comma e.g <pattern>,, if desired to return pattern match plus all at end! |
||||||
|
#todo - move to punk::pipe |
||||||
|
proc _split_patterns {varspecs} { |
||||||
|
|
||||||
|
set varlist [list] |
||||||
|
# @ @@ - list and dict functions |
||||||
|
# / level separator |
||||||
|
# # list count, ## dict size |
||||||
|
# % string functions |
||||||
|
# ! not |
||||||
|
set var_terminals [list "@" "/" "#" "%" "!" ">" "<"] ;# (> required for insertionspecs at rhs of = & .= ) |
||||||
|
#right bracket ) also ends a var - but is different depending on whether var is array or basic. For array - it forms part of the varname |
||||||
|
|
||||||
|
#except when prefixed directly by pin classifier ^ |
||||||
|
set protect_terminals [list "^"] ;# e.g sequence ^# |
||||||
|
#also - an atom usually doesn't need the / as a terminal - because it can't match a missing element unless it's empty string |
||||||
|
#ie the one usecase is '/n to match either empty string or missing item at position n. For this one usecase - we miss the capability to atom match paths/urls .. '/usr/local/et' |
||||||
|
set in_brackets 0 ;#count depth |
||||||
|
set in_atom 0 |
||||||
|
set token "" |
||||||
|
set end_var_posn -1 ;#first var_terminal encountered within each comma delimited section |
||||||
|
set token_index 0 ;#index of terminal char within each token |
||||||
|
set indq 0 |
||||||
|
set inbraces 0 |
||||||
|
set inesc 0 ;#whether last char was backslash (see also punk::escv) |
||||||
|
set prevc "" |
||||||
|
set char_index 0 |
||||||
|
#if {[string index $varspecs end] eq ","} { |
||||||
|
# set varspecs [string range $varspecs 0 end-1] |
||||||
|
#} |
||||||
|
set charcount 0 |
||||||
|
foreach c [split $varspecs ""] { |
||||||
|
incr charcount |
||||||
|
if {$indq} { |
||||||
|
if {$inesc} { |
||||||
|
#puts stderr "inesc adding '$c'" |
||||||
|
append token \\$c |
||||||
|
} else { |
||||||
|
if {$c eq {"}} { |
||||||
|
set indq 0 |
||||||
|
} else { |
||||||
|
append token $c |
||||||
|
} |
||||||
|
} |
||||||
|
} elseif {$inbraces} { |
||||||
|
if {$inesc} { |
||||||
|
append token \\$c |
||||||
|
} else { |
||||||
|
if {$c eq "\}"} { |
||||||
|
incr inbraces -1 |
||||||
|
if {$inbraces} { |
||||||
|
append token $c |
||||||
|
} |
||||||
|
} elseif {$c eq "\{"} { |
||||||
|
incr inbraces |
||||||
|
if {$inbraces} { |
||||||
|
append token $c |
||||||
|
} |
||||||
|
} else { |
||||||
|
append token $c |
||||||
|
} |
||||||
|
} |
||||||
|
} elseif {$in_atom} { |
||||||
|
#ignore dquotes/brackets in atoms - pass through |
||||||
|
append token $c |
||||||
|
#set nextc [lindex $chars $char_index+1] |
||||||
|
if {$c eq "'"} { |
||||||
|
set in_atom 0 |
||||||
|
} |
||||||
|
} elseif {$in_brackets > 0} { |
||||||
|
append token $c |
||||||
|
if {$c eq ")"} { |
||||||
|
incr in_brackets -1 |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {$c eq {"}} { |
||||||
|
if {!$inesc} { |
||||||
|
set indq 1 |
||||||
|
} else { |
||||||
|
append token $c |
||||||
|
} |
||||||
|
} elseif {$c eq "\{"} { |
||||||
|
if {!$inesc} { |
||||||
|
set inbraces 1 |
||||||
|
} else { |
||||||
|
append token $c |
||||||
|
} |
||||||
|
} elseif {$c eq ","} { |
||||||
|
#set var $token |
||||||
|
#set spec "" |
||||||
|
#if {$end_var_posn > 0} { |
||||||
|
# #tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
||||||
|
# #lassign [scan $token %${end_var_posn}s%s] var spec |
||||||
|
# set var [string range $token 0 $end_var_posn-1] |
||||||
|
# set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||||
|
#} else { |
||||||
|
# if {$end_var_posn == 0} { |
||||||
|
# set var "" |
||||||
|
# set spec $token |
||||||
|
# } |
||||||
|
#} |
||||||
|
#lappend varlist [list [string trim $var] [string trim $spec]] |
||||||
|
#set token "" |
||||||
|
#set token_index -1 ;#reduce by 1 because , not included in next token |
||||||
|
#set end_var_posn -1 |
||||||
|
} else { |
||||||
|
append token $c |
||||||
|
switch -exact -- $c { |
||||||
|
' { |
||||||
|
set in_atom 1 |
||||||
|
} |
||||||
|
( { |
||||||
|
incr in_brackets |
||||||
|
} |
||||||
|
default { |
||||||
|
if {$end_var_posn == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { |
||||||
|
set end_var_posn $token_index |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {$c eq ","} { |
||||||
|
set var $token |
||||||
|
set spec "" |
||||||
|
if {$end_var_posn > 0} { |
||||||
|
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
||||||
|
#lassign [scan $token %${end_var_posn}s%s] var spec |
||||||
|
set var [string range $token 0 $end_var_posn-1] |
||||||
|
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||||
|
} else { |
||||||
|
if {$end_var_posn == 0} { |
||||||
|
set var "" |
||||||
|
set spec $token |
||||||
|
} |
||||||
|
} |
||||||
|
lappend varlist [list [string trim $var] $spec] |
||||||
|
set token "" |
||||||
|
set token_index -1 |
||||||
|
set end_var_posn -1 |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$charcount == [string length $varspecs]} { |
||||||
|
if {!($indq || $inbraces || $in_atom || $in_brackets)} { |
||||||
|
if {$c ne ","} { |
||||||
|
set var $token |
||||||
|
set spec "" |
||||||
|
if {$end_var_posn > 0} { |
||||||
|
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
||||||
|
#lassign [scan $token %${end_var_posn}s%s] var spec |
||||||
|
set var [string range $token 0 $end_var_posn-1] |
||||||
|
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||||
|
} else { |
||||||
|
if {$end_var_posn == 0} { |
||||||
|
set var "" |
||||||
|
set spec $token |
||||||
|
} |
||||||
|
} |
||||||
|
lappend varlist [list [string trim $var] $spec] |
||||||
|
set token "" |
||||||
|
set token_index -1 |
||||||
|
set end_var_posn -1 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set prevc $c |
||||||
|
if {$c eq "\\"} { |
||||||
|
#review |
||||||
|
if {$inesc} { |
||||||
|
set inesc 0 |
||||||
|
} else { |
||||||
|
set token [string range $token 0 end-1] |
||||||
|
set inesc 1 |
||||||
|
} |
||||||
|
} else { |
||||||
|
set inesc 0 |
||||||
|
} |
||||||
|
incr token_index |
||||||
|
incr char_index |
||||||
|
} |
||||||
|
|
||||||
|
#if {[string length $token]} { |
||||||
|
# #lappend varlist [splitstrposn $token $end_var_posn] |
||||||
|
# set var $token |
||||||
|
# set spec "" |
||||||
|
# if {$end_var_posn > 0} { |
||||||
|
# #lassign [scan $token %${end_var_posn}s%s] var spec |
||||||
|
# set var [string range $token 0 $end_var_posn-1] |
||||||
|
# set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||||
|
# } else { |
||||||
|
# if {$end_var_posn == 0} { |
||||||
|
# set var "" |
||||||
|
# set spec $token |
||||||
|
# } |
||||||
|
# } |
||||||
|
# #lappend varlist [list [string trim $var] [string trim $spec]] |
||||||
|
# #spec needs to be able to match whitespace too |
||||||
|
# lappend varlist [list [string trim $var] $spec] |
||||||
|
#} |
||||||
|
|
||||||
|
return $varlist |
||||||
|
} |
||||||
|
|
||||||
|
#todo - consider whether we can use < for insertion/iteration combinations |
||||||
|
# =a<,b< iterate once through |
||||||
|
# =a><,b>< cartesian product |
||||||
|
# =a<>,b<> ??? zip ? |
||||||
|
# |
||||||
|
# ie = {a b c} |> .=< inspect |
||||||
|
# would call inspect 3 times, once for each argument |
||||||
|
# .= list {a b c} {x y z} |a/0,b/1> .=a><,b>< list |
||||||
|
# would produce list of cartesian pairs? |
||||||
|
# |
||||||
|
proc _split_equalsrhs {insertionpattern} { |
||||||
|
#map the insertionpattern so we can use faster globless info command search |
||||||
|
set name_mapped [pipecmd_namemapping $insertionpattern] |
||||||
|
set cmdname ::punk::pipecmds::split_rhs::_$name_mapped |
||||||
|
if {[info commands $cmdname] ne ""} { |
||||||
|
return [$cmdname] |
||||||
|
} |
||||||
|
|
||||||
|
set lst_var_indexposition [_split_patterns_memoized $insertionpattern] |
||||||
|
set i 0 |
||||||
|
set return_triples [list] |
||||||
|
foreach v_pos $lst_var_indexposition { |
||||||
|
lassign $v_pos v index_and_position |
||||||
|
#e.g varname@@data/ok>0 varname/1/0>end |
||||||
|
#ensure only one ">" is detected |
||||||
|
if {![string length $index_and_position]} { |
||||||
|
set indexspec "" |
||||||
|
set positionspec "" |
||||||
|
} else { |
||||||
|
set chars [split $index_and_position ""] |
||||||
|
set posns [lsearch -all $chars ">"] |
||||||
|
if {[llength $posns] > 1} { |
||||||
|
error "pipesyntax error in segment insertion pattern '$insertionpattern' -v '$v' multiple '>' characters. Pattern not understood." "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] |
||||||
|
} |
||||||
|
if {![llength $posns]} { |
||||||
|
set indexspec $index_and_position |
||||||
|
set positionspec "" |
||||||
|
} else { |
||||||
|
set splitposn [lindex $posns 0] |
||||||
|
set indexspec [string range $index_and_position 0 $splitposn-1] |
||||||
|
set positionspec [string range $index_and_position $splitposn+1 end] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#review - |
||||||
|
if {($positionspec in [list "*" "/*" "@*" "/" "@"]) || ($v eq "*" && $positionspec eq "")} { |
||||||
|
set star "" |
||||||
|
if {$v eq "*"} { |
||||||
|
set v "" |
||||||
|
set star "*" |
||||||
|
} |
||||||
|
if {[string index $positionspec end] eq "*"} { |
||||||
|
set star "*" |
||||||
|
} |
||||||
|
#it is always possible to insert at end of list regardless of current length - so /end* and @end* are equivalent |
||||||
|
#as are /end and @end |
||||||
|
#lset lst_var_indexposition $i [list $v "/end$star"] |
||||||
|
set triple [list $v $indexspec "/end$star"] |
||||||
|
} else { |
||||||
|
if {$positionspec eq ""} { |
||||||
|
#e.g just =varname |
||||||
|
#lset lst_var_indexposition $i [list $v "/end"] |
||||||
|
set triple [list $v $indexspec "/end"] |
||||||
|
#error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' missing position spec e.g /0" |
||||||
|
} else { |
||||||
|
if {[string index $indexspec 0] ni [list "" "/" "@"]} { |
||||||
|
error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' bad index spec '$indexspec'" "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] |
||||||
|
} |
||||||
|
set triple [list $v $indexspec $positionspec] |
||||||
|
} |
||||||
|
} |
||||||
|
lappend return_triples $triple |
||||||
|
incr i |
||||||
|
} |
||||||
|
proc $cmdname {} [list return $return_triples] |
||||||
|
return $return_triples |
||||||
|
} |
||||||
|
|
||||||
|
proc _rhs_tail_split {fullrhs} { |
||||||
|
set inq 0; set indq 0 |
||||||
|
set equalsrhs "" |
||||||
|
set i 0 |
||||||
|
foreach ch [split $fullrhs ""] { |
||||||
|
if {$inq} { |
||||||
|
append equalsrhs $ch |
||||||
|
if {$ch eq {'}} { |
||||||
|
set inq 0 |
||||||
|
} |
||||||
|
} elseif {$indq} { |
||||||
|
append equalsrhs $ch |
||||||
|
if {$ch eq {"}} { |
||||||
|
set indq 0 |
||||||
|
} |
||||||
|
} else { |
||||||
|
switch -- $ch { |
||||||
|
{'} { |
||||||
|
set inq 1 |
||||||
|
} |
||||||
|
{"} { |
||||||
|
set indq 1 |
||||||
|
} |
||||||
|
" " { |
||||||
|
#whitespace outside of quoting |
||||||
|
break |
||||||
|
} |
||||||
|
0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - z {} |
||||||
|
default { |
||||||
|
#\t not a literal for switch jumpTable bytecompile - review - can we do it without for example string mapping to <t> (and without a literal binary tab in source file)? |
||||||
|
#we can't (reliably?) put \t as one of our switch keys |
||||||
|
# |
||||||
|
if {$ch eq "\t"} { |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
append equalsrhs $ch |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
set tail [tcl::string::range $fullrhs $i end] |
||||||
|
return [list $equalsrhs $tail] |
||||||
|
} |
||||||
|
|
||||||
|
#todo - recurse into bracketed sub parts |
||||||
|
#JMN3 |
||||||
|
#e.g @*/(x@0,y@2) |
||||||
|
proc _var_classify {multivar} { |
||||||
|
set cmdname ::punk::pipecmds::var_classify::_[pipecmd_namemapping $multivar] |
||||||
|
if {[info commands $cmdname] ne ""} { |
||||||
|
return [$cmdname] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#comma seems a natural choice to split varspecs, |
||||||
|
#but also for list and dict subelement access |
||||||
|
#/ normally indicates some sort of hierarchical separation - (e.g in filesytems) |
||||||
|
#so / will indicate subelements e.g @0/1 for lindex $list 0 1 |
||||||
|
#set valsource_key_list [_split_var_key_at_unbracketed_comma $multivar] |
||||||
|
set valsource_key_list [_split_patterns_memoized $multivar] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#mutually exclusive - atom/pin |
||||||
|
#set map [list "" ' ^ &] ;#0 = default/var/not-yet-determined 1 = atom 2 = pin |
||||||
|
#set var_class [lmap var $valsource_key_list {expr {([set m [lsearch $map [string index [lindex $var 0] 0]]] >= 0) ? [list $var $m] : [list $var 0]}}] |
||||||
|
#0 - novar |
||||||
|
#1 - atom ' |
||||||
|
#2 - pin ^ |
||||||
|
#3 - boolean & |
||||||
|
#4 - integer |
||||||
|
#5 - double |
||||||
|
#6 - var |
||||||
|
#7 - glob (no classifier and contains * or ?) |
||||||
|
#8 - numeric |
||||||
|
#9 - > (+) |
||||||
|
#10 - < (-) |
||||||
|
|
||||||
|
set var_names [list] |
||||||
|
set var_class [list] |
||||||
|
set varspecs_trimmed [list] ;#raw varspecs without pin/atom modifiers - or empty string for glob |
||||||
|
|
||||||
|
|
||||||
|
set leading_classifiers [list "'" "&" "^" ] |
||||||
|
set trailing_classifiers [list + -] |
||||||
|
set possible_number_start [list - + . 0 1 2 3 4 5 6 7 8 9 > <] |
||||||
|
|
||||||
|
foreach v_key $valsource_key_list { |
||||||
|
lassign $v_key v key |
||||||
|
set vname $v ;#default |
||||||
|
set classes [list] |
||||||
|
if {$v eq ""} { |
||||||
|
lappend var_class [list $v_key 0] |
||||||
|
lappend varspecs_trimmed $v_key |
||||||
|
} else { |
||||||
|
set lastchar [string index $v end] |
||||||
|
switch -- $lastchar { |
||||||
|
+ { |
||||||
|
lappend classes 9 |
||||||
|
set vname [string range $v 0 end-1] |
||||||
|
} |
||||||
|
- { |
||||||
|
lappend classes 10 |
||||||
|
set vname [string range $v 0 end-1] |
||||||
|
} |
||||||
|
} |
||||||
|
set firstchar [string index $v 0] |
||||||
|
switch -- $firstchar { |
||||||
|
' { |
||||||
|
lappend var_class [list $v_key 1] |
||||||
|
#set vname [string range $v 1 end] |
||||||
|
lappend varspecs_trimmed [list $vname $key] |
||||||
|
} |
||||||
|
^ { |
||||||
|
lappend classes [list 2] |
||||||
|
#use vname - may already have trailing +/- stripped |
||||||
|
set vname [string range $vname 1 end] |
||||||
|
set secondclassifier [string index $v 1] |
||||||
|
switch -- $secondclassifier { |
||||||
|
"&" { |
||||||
|
#pinned boolean |
||||||
|
lappend classes 3 |
||||||
|
set vname [string range $v 2 end] |
||||||
|
} |
||||||
|
"#" { |
||||||
|
#pinned numeric comparison instead of string comparison |
||||||
|
#e.g set x 2 |
||||||
|
# this should match: ^#x.= list 2.0 |
||||||
|
lappend classes 8 |
||||||
|
set vname [string range $vname 1 end] |
||||||
|
} |
||||||
|
"*" { |
||||||
|
#pinned glob |
||||||
|
lappend classes 7 |
||||||
|
set vname [string range $v 2 end] |
||||||
|
} |
||||||
|
} |
||||||
|
#todo - check for second tag - & for pinned boolean? |
||||||
|
#consider requiring ^# for numeric comparisons. currently no way to do a strictly string comparison on pinned variables.... default ^var really shouldn't be doing any magic. |
||||||
|
#while we're at it.. pinned glob would be nice. ^* |
||||||
|
#maybe even pinned scan ^% ? regex? ^/ or ^? these would be hard to have corresponding literals in the pattern mini-lang. |
||||||
|
#These all limit the range of varnames permissible - which is no big deal. |
||||||
|
lappend var_class [list $v_key $classes] |
||||||
|
lappend varspecs_trimmed [list $vname $key] |
||||||
|
} |
||||||
|
& { |
||||||
|
#we require boolean literals to be single-quoted so we can use cross-binding on boolean vars. |
||||||
|
#ie &true is the variable true whereas &'true' or &'1' &'t' etc are literal booleans |
||||||
|
#allow exception of &1 &0 to be literal booleans - because we disallow 0 & 1 as varnames in other contexts anyway - so it would be more consistent not to treat as varnames here. |
||||||
|
lappend var_class [list $v_key 3] |
||||||
|
set vname [string range $v 1 end] |
||||||
|
lappend varspecs_trimmed [list $vname $key] |
||||||
|
} |
||||||
|
default { |
||||||
|
if {([string first ? $v]) >=0 || ([string first * $v] >=0)} { |
||||||
|
lappend var_class [list $v_key 7] ;#glob |
||||||
|
#leave vname as the full glob |
||||||
|
lappend varspecs_trimmed [list "" $key] |
||||||
|
} else { |
||||||
|
#scan vname not v - will either be same as v - or possibly stripped of trailing +/- |
||||||
|
set numtestv [join [scan $vname %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, decimal points and sci notation - fails to handle leading dot e.g .5 |
||||||
|
#leading . still need to test directly for double |
||||||
|
if {[string is double -strict $vname] || [string is double -strict $numtestv]} { |
||||||
|
if {[string is integer -strict $numtestv]} { |
||||||
|
#this will pick up boolean 1 or 0 - but that's ok - they require "&" marker if boolean comparison desired |
||||||
|
#integer test before double.. |
||||||
|
#note there is also string is wide (string is wideinteger) for larger ints.. |
||||||
|
lappend classes 4 |
||||||
|
lappend var_class [list $v_key $classes] |
||||||
|
lappend varspecs_trimmed $v_key |
||||||
|
} else { |
||||||
|
#double |
||||||
|
#sci notation 1e123 etc |
||||||
|
#also large numbers like 1000000000 - even without decimal point - (tcl bignum) |
||||||
|
lappend classes 5 |
||||||
|
lappend var_class [list $v_key $classes] |
||||||
|
lappend varspecs_trimmed $v_key |
||||||
|
} |
||||||
|
} else { |
||||||
|
lappend var_class [list $v_key 6] ;#var |
||||||
|
lappend varspecs_trimmed $v_key |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
lappend var_names $vname |
||||||
|
} |
||||||
|
|
||||||
|
set result [list var_names $var_names var_class $var_class varspecs_trimmed $varspecs_trimmed] |
||||||
|
|
||||||
|
proc $cmdname {} [list return $result] |
||||||
|
#JMN |
||||||
|
#debug.punk.pipe.compile {proc $cmdname} |
||||||
|
return $result |
||||||
|
} |
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::pipe::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval punk::pipe::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::pipe::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
# Sample 'about' function with punk::args documentation |
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
tcl::namespace::eval punk::pipe { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
variable PUNKARGS |
||||||
|
variable PUNKARGS_aliases |
||||||
|
|
||||||
|
lappend PUNKARGS [list { |
||||||
|
@id -id "(package)punk::pipe" |
||||||
|
@package -name "punk::pipe" -help\ |
||||||
|
"Package |
||||||
|
Description" |
||||||
|
}] |
||||||
|
|
||||||
|
namespace eval argdoc { |
||||||
|
#namespace for custom argument documentation |
||||||
|
proc package_name {} { |
||||||
|
return punk::pipe |
||||||
|
} |
||||||
|
proc about_topics {} { |
||||||
|
#info commands results are returned in an arbitrary order (like array keys) |
||||||
|
set topic_funs [info commands [namespace current]::get_topic_*] |
||||||
|
set about_topics [list] |
||||||
|
foreach f $topic_funs { |
||||||
|
set tail [namespace tail $f] |
||||||
|
lappend about_topics [string range $tail [string length get_topic_] end] |
||||||
|
} |
||||||
|
return $about_topics |
||||||
|
} |
||||||
|
proc default_topics {} {return [list Description outline *]} |
||||||
|
|
||||||
|
# ------------------------------------------------------------- |
||||||
|
# get_topic_ functions add more to auto-include in about topics |
||||||
|
# ------------------------------------------------------------- |
||||||
|
proc get_topic_Description {} { |
||||||
|
punk::args::lib::tstr [string trim { |
||||||
|
punk pipeline features |
||||||
|
} \n] |
||||||
|
} |
||||||
|
proc get_topic_License {} { |
||||||
|
return "MIT" |
||||||
|
} |
||||||
|
proc get_topic_Version {} { |
||||||
|
return $::punk::pipe::version |
||||||
|
} |
||||||
|
proc get_topic_Contributors {} { |
||||||
|
set authors {{Julian Noble <julian@precisium.com.au>}} |
||||||
|
set contributors "" |
||||||
|
foreach a $authors { |
||||||
|
append contributors $a \n |
||||||
|
} |
||||||
|
if {[string index $contributors end] eq "\n"} { |
||||||
|
set contributors [string range $contributors 0 end-1] |
||||||
|
} |
||||||
|
return $contributors |
||||||
|
} |
||||||
|
proc get_topic_outline {} { |
||||||
|
punk::args::lib::tstr -return string { |
||||||
|
todo.. |
||||||
|
} |
||||||
|
} |
||||||
|
# ------------------------------------------------------------- |
||||||
|
} |
||||||
|
|
||||||
|
# we re-use the argument definition from punk::args::standard_about and override some items |
||||||
|
set overrides [dict create] |
||||||
|
dict set overrides @id -id "::punk::pipe::about" |
||||||
|
dict set overrides @cmd -name "punk::pipe::about" |
||||||
|
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||||
|
About punk::pipe |
||||||
|
}] \n] |
||||||
|
dict set overrides topic -choices [list {*}[punk::pipe::argdoc::about_topics] *] |
||||||
|
dict set overrides topic -choicerestricted 1 |
||||||
|
dict set overrides topic -default [punk::pipe::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||||
|
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||||
|
lappend PUNKARGS [list $newdef] |
||||||
|
proc about {args} { |
||||||
|
package require punk::args |
||||||
|
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||||
|
set argd [punk::args::parse $args withid ::punk::pipe::about] |
||||||
|
lassign [dict values $argd] _leaders opts values _received |
||||||
|
punk::args::package::standard_about -package_about_namespace ::punk::pipe::argdoc {*}$opts {*}[dict get $values topic] |
||||||
|
} |
||||||
|
} |
||||||
|
# end of sample 'about' function |
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
|
||||||
|
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::pipe |
||||||
|
} |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::pipe [tcl::namespace::eval punk::pipe { |
||||||
|
variable pkg punk::pipe |
||||||
|
variable version |
||||||
|
set version 1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,276 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::repl::codethread 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::repl::codethread 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::repl::codethread] |
||||||
|
#[keywords module repl] |
||||||
|
#[description] |
||||||
|
#[para] This is part of the infrastructure required for the punk::repl to operate |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::repl::codethread |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::repl::codethread |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require punk::config |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::repl::codethread::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread::class}] |
||||||
|
#[para] class definitions |
||||||
|
#if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
#} |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::repl::codethread { |
||||||
|
tcl::namespace::export * |
||||||
|
variable replthread |
||||||
|
variable replthread_cond |
||||||
|
variable running 0 |
||||||
|
|
||||||
|
variable output_stdout "" |
||||||
|
variable output_stderr "" |
||||||
|
|
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread}] |
||||||
|
#[para] Core API functions for punk::repl::codethread |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#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" |
||||||
|
#} |
||||||
|
|
||||||
|
variable run_command_cache |
||||||
|
|
||||||
|
proc is_running {} { |
||||||
|
variable running |
||||||
|
return $running |
||||||
|
} |
||||||
|
proc runscript {script} { |
||||||
|
|
||||||
|
#puts stderr "->runscript" |
||||||
|
variable replthread_cond |
||||||
|
#variable output_stdout |
||||||
|
#set output_stdout "" |
||||||
|
#variable output_stderr |
||||||
|
#set output_stderr "" |
||||||
|
#expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available |
||||||
|
#if a thread::send is done from the commandline in a codethread - Tcl will |
||||||
|
if {"code" ni [interp children] || ![info exists replthread_cond]} { |
||||||
|
#in case someone tries calling from codethread directly - don't do anything or change any state |
||||||
|
#(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful) |
||||||
|
#if called directly - the context will be within the first 'code' interp. |
||||||
|
#inappropriate caller could add superfluous entries to shellfilter stack if function errors out |
||||||
|
#inappropriate caller could affect tsv vars (if their interp allows that anyway) |
||||||
|
puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread" |
||||||
|
return |
||||||
|
} |
||||||
|
interp eval code [list set ::punk::repl::codethread::output_stdout ""] |
||||||
|
interp eval code [list set ::punk::repl::codethread::output_stderr ""] |
||||||
|
|
||||||
|
set outstack [list] |
||||||
|
set errstack [list] |
||||||
|
upvar ::punk::config::running running_config |
||||||
|
if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} { |
||||||
|
lappend outstack [interp eval code [list shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]] |
||||||
|
} |
||||||
|
lappend outstack [interp eval code [list shellfilter::stack::add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]] |
||||||
|
|
||||||
|
if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} { |
||||||
|
lappend errstack [interp eval code [list shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]] |
||||||
|
# #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]] |
||||||
|
} |
||||||
|
lappend errstack [interp eval code [list shellfilter::stack::add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]] |
||||||
|
|
||||||
|
#an experiment |
||||||
|
#set errhandle [shellfilter::stack::item_tophandle stderr] |
||||||
|
#interp transfer "" $errhandle code |
||||||
|
|
||||||
|
set status [catch { |
||||||
|
#shennanigans to keep compiled script around after call. |
||||||
|
#otherwise when $script goes out of scope - internal rep of vars set in script changes. |
||||||
|
#The shimmering may be no big deal(?) - but debug/analysis using tcl::unsupported::representation becomes impossible. |
||||||
|
interp eval code [list ::punk::lib::set_clone ::codeinterp::clonescript $script] ;#like objclone |
||||||
|
interp eval code { |
||||||
|
lappend ::codeinterp::run_command_cache $::codeinterp::clonescript |
||||||
|
if {[llength $::codeinterp::run_command_cache] > 2000} { |
||||||
|
set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache] |
||||||
|
} |
||||||
|
tcl::namespace::inscope $::punk::ns::ns_current $::codeinterp::clonescript |
||||||
|
} |
||||||
|
} result] |
||||||
|
|
||||||
|
|
||||||
|
flush stdout |
||||||
|
flush stderr |
||||||
|
|
||||||
|
#interp transfer code $errhandle "" |
||||||
|
#flush $errhandle |
||||||
|
set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end] |
||||||
|
set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end] |
||||||
|
#puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]" |
||||||
|
|
||||||
|
set tid [thread::id] |
||||||
|
tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] |
||||||
|
tsv::set codethread_$tid status $status |
||||||
|
tsv::set codethread_$tid result $result |
||||||
|
tsv::set codethread_$tid errorcode $::errorCode |
||||||
|
|
||||||
|
|
||||||
|
#only remove from shellfilter::stack the items we added to stack in this function |
||||||
|
foreach s [lreverse $outstack] { |
||||||
|
interp eval code [list shellfilter::stack::remove stdout $s] |
||||||
|
} |
||||||
|
foreach s [lreverse $errstack] { |
||||||
|
interp eval code [list shellfilter::stack::remove stderr $s] |
||||||
|
} |
||||||
|
thread::cond notify $replthread_cond |
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::repl::codethread ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::repl::codethread::lib { |
||||||
|
tcl::namespace::export * |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread::lib}] |
||||||
|
#[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 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::repl::codethread::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
tcl::namespace::eval punk::repl::codethread::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread { |
||||||
|
variable pkg punk::repl::codethread |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,321 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::repl::codethread 0.1.1 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin punkshell_module_punk::repl::codethread 0 0.1.1] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::repl::codethread] |
||||||
|
#[keywords module repl] |
||||||
|
#[description] |
||||||
|
#[para] This is part of the infrastructure required for the punk::repl to operate |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::repl::codethread |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::repl::codethread |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require punk::config |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::repl::codethread::class { |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread::class}] |
||||||
|
#[para] class definitions |
||||||
|
|
||||||
|
#if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
|
||||||
|
#} |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::repl::codethread { |
||||||
|
tcl::namespace::export * |
||||||
|
variable replthread |
||||||
|
variable replthread_cond |
||||||
|
variable running 0 |
||||||
|
|
||||||
|
variable output_stdout "" |
||||||
|
variable output_stderr "" |
||||||
|
|
||||||
|
#review/test |
||||||
|
catch {package require punk::ns} |
||||||
|
catch {package rquire punk::repl} |
||||||
|
|
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread}] |
||||||
|
#[para] Core API functions for punk::repl::codethread |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#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" |
||||||
|
#} |
||||||
|
|
||||||
|
variable run_command_cache |
||||||
|
|
||||||
|
#Use interp exists instead.. |
||||||
|
#if {[catch {interp children}]} { |
||||||
|
# #8.6.10 doesn't have it.. when was it introduced? |
||||||
|
#} else { |
||||||
|
|
||||||
|
#} |
||||||
|
|
||||||
|
proc is_running {} { |
||||||
|
variable running |
||||||
|
return $running |
||||||
|
} |
||||||
|
proc runscript {script} { |
||||||
|
|
||||||
|
#puts stderr "->runscript" |
||||||
|
variable replthread_cond |
||||||
|
#variable output_stdout "" |
||||||
|
#variable output_stderr "" |
||||||
|
|
||||||
|
#expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available |
||||||
|
#if a thread::send is done from the commandline in a codethread - Tcl will |
||||||
|
if {![interp exists code] || ![info exists replthread_cond]} { |
||||||
|
#in case someone tries calling from codethread directly - don't do anything or change any state |
||||||
|
#(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful) |
||||||
|
#if called directly - the context will be within the first 'code' interp. |
||||||
|
#inappropriate caller could add superfluous entries to shellfilter stack if function errors out |
||||||
|
#inappropriate caller could affect tsv vars (if their interp allows that anyway) |
||||||
|
puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread" |
||||||
|
return |
||||||
|
} |
||||||
|
interp eval code [list set ::punk::repl::codethread::output_stdout ""] |
||||||
|
interp eval code [list set ::punk::repl::codethread::output_stderr ""] |
||||||
|
|
||||||
|
set outstack [list] |
||||||
|
set errstack [list] |
||||||
|
upvar ::punk::config::running running_config |
||||||
|
if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} { |
||||||
|
lappend outstack [interp eval code [list ::shellfilter::stack add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]] |
||||||
|
} |
||||||
|
lappend outstack [interp eval code [list ::shellfilter::stack add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]] |
||||||
|
|
||||||
|
if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} { |
||||||
|
lappend errstack [interp eval code [list ::shellfilter::stack add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]] |
||||||
|
# #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]] |
||||||
|
} |
||||||
|
lappend errstack [interp eval code [list ::shellfilter::stack add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]] |
||||||
|
|
||||||
|
#an experiment |
||||||
|
#set errhandle [shellfilter::stack::item_tophandle stderr] |
||||||
|
#interp transfer "" $errhandle code |
||||||
|
|
||||||
|
set status [catch { |
||||||
|
#shennanigans to keep compiled script around after call. |
||||||
|
#otherwise when $script goes out of scope - internal rep of vars set in script changes. |
||||||
|
#The shimmering may be no big deal(?) - but debug/analysis using tcl::unsupported::representation becomes impossible. |
||||||
|
|
||||||
|
#interp eval code [list ::punk::lib::set_clone ::codeinterp::clonescript $script] ;#like objclone |
||||||
|
interp eval code [list ::codeinterp::set_clone ::codeinterp::clonescript $script] ;#like objclone |
||||||
|
|
||||||
|
interp eval code {lappend ::codeinterp::run_command_cache $::codeinterp::clonescript} |
||||||
|
|
||||||
|
interp eval code { |
||||||
|
#lappend ::codeinterp::run_command_cache $::codeinterp::clonescript |
||||||
|
if {[llength $::codeinterp::run_command_cache] > 2000} { |
||||||
|
set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache] |
||||||
|
} |
||||||
|
if {[string first ":::" $::punk::ns::ns_current] >= 0} { |
||||||
|
#support for browsing 'odd' (inadvisable) namespaces |
||||||
|
#don't use 'namespace exists' - will conflate ::test::x with ::test:::x |
||||||
|
#if {$::punk::ns::ns_current in [namespace children [punk::ns::nsprefix $::punk::ns::ns_current]} { |
||||||
|
#} |
||||||
|
package require punk::ns |
||||||
|
punk::ns::nseval_ifexists $::punk::ns::ns_current $::codeinterp::clonescript |
||||||
|
} else { |
||||||
|
if {![namespace exists $::punk::ns::ns_current]} { |
||||||
|
namespace eval $::punk::ns::ns_current { |
||||||
|
puts stderr "Created namespace: $::punk::ns::ns_current" |
||||||
|
} |
||||||
|
} |
||||||
|
tcl::namespace::inscope $::punk::ns::ns_current $::codeinterp::clonescript |
||||||
|
} |
||||||
|
} |
||||||
|
} result] |
||||||
|
#temp test for subshell experimentation |
||||||
|
#if {$status == 1} { |
||||||
|
# puts stderr "--codethread::runscript error--------\n$::errorInfo" |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
flush stdout |
||||||
|
flush stderr |
||||||
|
|
||||||
|
#interp transfer code $errhandle "" |
||||||
|
#flush $errhandle |
||||||
|
#set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end] |
||||||
|
#set lastoutchar [string index [punk::ansi::ansistrip [interp eval code [list set ::punk::repl::codethread::output_stdout]]] end] |
||||||
|
set lastoutpart [interp eval code {string range $::punk::repl::codethread::output_stdout end-100 end}] |
||||||
|
#note we could be in a *large* ansi segment such as sixel data |
||||||
|
#review - why do we need to ansistrip? |
||||||
|
set lastoutchar [string index [punk::ansi::ansistrip $lastoutpart] end] |
||||||
|
|
||||||
|
#set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end] |
||||||
|
set lasterrpart [interp eval code {string range $::punk::repl::codethread::output_stderr end-100 end}] |
||||||
|
set lasterrchar [string index [punk::ansi::ansistrip $lasterrpart] end] |
||||||
|
#puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]" |
||||||
|
|
||||||
|
set tid [thread::id] |
||||||
|
tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] |
||||||
|
tsv::set codethread_$tid status $status |
||||||
|
tsv::set codethread_$tid result $result |
||||||
|
tsv::set codethread_$tid errorcode $::errorCode |
||||||
|
|
||||||
|
|
||||||
|
#only remove from shellfilter::stack the items we added to stack in this function |
||||||
|
foreach s [lreverse $outstack] { |
||||||
|
interp eval code [list ::shellfilter::stack remove stdout $s] |
||||||
|
} |
||||||
|
foreach s [lreverse $errstack] { |
||||||
|
interp eval code [list ::shellfilter::stack remove stderr $s] |
||||||
|
} |
||||||
|
thread::cond notify $replthread_cond |
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::repl::codethread ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::repl::codethread::lib { |
||||||
|
tcl::namespace::export * |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread::lib}] |
||||||
|
#[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 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::repl::codethread::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
tcl::namespace::eval punk::repl::codethread::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread { |
||||||
|
variable pkg punk::repl::codethread |
||||||
|
variable version |
||||||
|
set version 0.1.1 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,605 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) CMcC 2010 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::trie 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin punkshell_module_punk::trie 0 0.1.0] |
||||||
|
#[copyright "2010"] |
||||||
|
#[titledesc {punk::trie API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {punk::trie}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::trie] |
||||||
|
#[keywords module datastructure trie] |
||||||
|
#[description] tcl trie implementation courtesy of CmcC (tcl wiki) |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::trie |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::trie |
||||||
|
#[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] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# #tcl::namespace::eval punk::trie::class { |
||||||
|
# #*** !doctools |
||||||
|
# #[subsection {Namespace punk::trie::class}] |
||||||
|
# #[para] class definitions |
||||||
|
# #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||||
|
# #*** !doctools |
||||||
|
# #[list_begin enumerated] |
||||||
|
# |
||||||
|
# # oo::class create interface_sample1 { |
||||||
|
# # #*** !doctools |
||||||
|
# # #[enum] CLASS [class interface_sample1] |
||||||
|
# # #[list_begin definitions] |
||||||
|
# |
||||||
|
# # method test {arg1} { |
||||||
|
# # #*** !doctools |
||||||
|
# # #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# # #[para] test method |
||||||
|
# # puts "test: $arg1" |
||||||
|
# # } |
||||||
|
# |
||||||
|
# # #*** !doctools |
||||||
|
# # #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# # } |
||||||
|
# |
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {--- end class enumeration ---}] |
||||||
|
# #} |
||||||
|
# #} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::trie { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
proc Dolog {lvl txt} { |
||||||
|
#return "$lvl -- $txt" |
||||||
|
#logger calls this in such a way that a straight uplevel can get us the vars/commands in messages substituted |
||||||
|
set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] punk::trie '[uplevel [list subst $txt]]'" |
||||||
|
puts stderr $msg |
||||||
|
} |
||||||
|
package require logger |
||||||
|
logger::initNamespace ::punk::trie |
||||||
|
foreach lvl [logger::levels] { |
||||||
|
interp alias {} ::punk::trie::Log_$lvl {} ::punk::trie::Dolog $lvl |
||||||
|
log::logproc $lvl ::punk::trie::Log_$lvl |
||||||
|
} |
||||||
|
#namespace path ::punk::trie::log |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::trie}] |
||||||
|
#[para] Core API functions for punk::trie |
||||||
|
if {[tcl::info::commands [tcl::namespace::current]::trieclass] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
oo::class create [tcl::namespace::current]::trieclass { |
||||||
|
#*** !doctools |
||||||
|
#[enum] CLASS [class trieclass] |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
variable trie id |
||||||
|
|
||||||
|
method matches {t what} { |
||||||
|
#*** !doctools |
||||||
|
#[call class::trieclass [method matches] [arg t] [arg what]] |
||||||
|
#[para] search for longest prefix, return matching prefix, element and suffix |
||||||
|
|
||||||
|
set matches {} |
||||||
|
set wlen [string length $what] |
||||||
|
foreach k [lsort -decreasing -dictionary [dict keys $t]] { |
||||||
|
set klen [string length $k] |
||||||
|
set match "" |
||||||
|
for {set i 0} {$i < $klen |
||||||
|
&& $i < $wlen |
||||||
|
&& [string index $k $i] eq [string index $what $i] |
||||||
|
} {incr i} { |
||||||
|
append match [string index $k $i] |
||||||
|
} |
||||||
|
if {$match ne ""} { |
||||||
|
lappend matches $match $k |
||||||
|
} |
||||||
|
} |
||||||
|
#Debug.trie {matches: $what -> $matches} |
||||||
|
::punk::trie::log::debug {matches: $what -> $matches} |
||||||
|
|
||||||
|
if {[dict size $matches]} { |
||||||
|
# find the longest matching prefix |
||||||
|
set match [lindex [lsort -dictionary [dict keys $matches]] end] |
||||||
|
set mel [dict get $matches $match] |
||||||
|
set suffix [string range $what [string length $match] end] |
||||||
|
|
||||||
|
return [list $match $mel $suffix] |
||||||
|
} else { |
||||||
|
return {} ;# no matches |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# return next unique id if there's no proffered value |
||||||
|
method id {value} { |
||||||
|
if {$value} { |
||||||
|
return $value |
||||||
|
} else { |
||||||
|
return [incr id] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# insert an element with a given optional value into trie |
||||||
|
# along path given by $args (no need to specify) |
||||||
|
method insert {what {value 0} args} { |
||||||
|
if {[llength $args]} { |
||||||
|
set t [dict get $trie {*}$args] |
||||||
|
} else { |
||||||
|
set t $trie |
||||||
|
} |
||||||
|
|
||||||
|
if {[dict exists $t $what]} { |
||||||
|
#Debug.trie {$what is an exact match on path ($args $what)} |
||||||
|
::punk::trie::log::debug {$what is an exact match on path ($args $what)} |
||||||
|
if {[catch {dict size [dict get $trie {*}$args $what]} size]} { |
||||||
|
# the match is a leaf - we're done |
||||||
|
} else { |
||||||
|
# the match is a dict - we have to add a null |
||||||
|
dict set trie {*}$args $what "" [my id $value] |
||||||
|
} |
||||||
|
|
||||||
|
return ;# exact match - no change |
||||||
|
} |
||||||
|
|
||||||
|
# search for longest prefix |
||||||
|
set match [my matches $t $what] |
||||||
|
|
||||||
|
if {![llength $match]} { |
||||||
|
;# no matching prefix - new element |
||||||
|
#Debug.trie {no matching prefix of '$what' in $t - add it on path ($args $what)} |
||||||
|
::punk::trie::log::debug {no matching prefix of '$what' in $t add it on path ($args $what)} |
||||||
|
dict set trie {*}$args $what [my id $value] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
lassign $match match mel suffix ;# prefix, element of match, suffix |
||||||
|
|
||||||
|
if {$match ne $mel} { |
||||||
|
# the matching element shares a prefix, but has a variant suffix |
||||||
|
# it must be split |
||||||
|
#Debug.trie {splitting '$mel' along '$match'} |
||||||
|
::punk::trie::log::debug {splitting '$mel' along '$match'} |
||||||
|
|
||||||
|
set melC [dict get $t $mel] |
||||||
|
dict unset trie {*}$args $mel |
||||||
|
dict set trie {*}$args $match [string range $mel [string length $match] end] $melC |
||||||
|
} |
||||||
|
|
||||||
|
if {[catch {dict size [dict get $trie {*}$args $match]} size]} { |
||||||
|
# the match is a leaf - must be split |
||||||
|
if {$match eq $mel} { |
||||||
|
# the matching element shares a prefix, but has a variant suffix |
||||||
|
# it must be split |
||||||
|
#Debug.trie {splitting '$mel' along '$match'} |
||||||
|
::punk::trie::log::debug {splitting '$mel' along '$match'} |
||||||
|
set melC [dict get $t $mel] |
||||||
|
dict unset trie {*}$args $mel |
||||||
|
dict set trie {*}$args $match "" $melC |
||||||
|
} |
||||||
|
#Debug.trie {'$mel' is the longest prefix '$match' but was a leaf - insert '$suffix'} |
||||||
|
::punk::trie::log::debug {'$mel' is the longest prefix '$match' but was a leaf - insert '$suffix'} |
||||||
|
set melid [dict get $t $mel] |
||||||
|
dict set trie {*}$args $match $suffix [my id $value] |
||||||
|
} else { |
||||||
|
# it's a dict - keep searching |
||||||
|
#Debug.trie {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} |
||||||
|
::punk::trie::log::debug {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} |
||||||
|
my insert $suffix $value {*}$args $match |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# find a path matching an element $what |
||||||
|
# if the element's not found, return the nearest path |
||||||
|
method find_path {what args} { |
||||||
|
if {[llength $args]} { |
||||||
|
set t [dict get $trie {*}$args] |
||||||
|
} else { |
||||||
|
set t $trie |
||||||
|
} |
||||||
|
|
||||||
|
if {[dict exists $t $what]} { |
||||||
|
#Debug.trie {$what is an exact match on path ($args $what)} |
||||||
|
return [list {*}$args $what] ;# exact match - no change |
||||||
|
} |
||||||
|
|
||||||
|
# search for longest prefix |
||||||
|
set match [my matches $t $what] |
||||||
|
|
||||||
|
if {![llength $match]} { |
||||||
|
return $args |
||||||
|
} |
||||||
|
|
||||||
|
lassign $match match mel suffix ;# prefix, element of match, suffix |
||||||
|
|
||||||
|
if {$match ne $mel} { |
||||||
|
# the matching element shares a prefix, but has a variant suffix |
||||||
|
# no match |
||||||
|
return $args |
||||||
|
} |
||||||
|
|
||||||
|
if {[catch {dict size [dict get $trie {*}$args $match]} size] || $size == 0} { |
||||||
|
# got to a non-matching leaf - no match |
||||||
|
return $args |
||||||
|
} else { |
||||||
|
# it's a dict - keep searching |
||||||
|
#Debug.trie {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} |
||||||
|
return [my find_path $suffix {*}$args $match] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# given a trie, which may have been modified by deletion, |
||||||
|
# optimize it by removing empty nodes and coalescing singleton nodes |
||||||
|
method optimize {args} { |
||||||
|
if {[llength $args]} { |
||||||
|
set t [dict get $trie {*}$args] |
||||||
|
} else { |
||||||
|
set t $trie |
||||||
|
} |
||||||
|
|
||||||
|
if {[catch {dict size $t} size]} { |
||||||
|
#Debug.trie {optimize leaf '$t' along '$args'} |
||||||
|
::punk::trie::log::debug {optimize leaf '$t' along '$args'} |
||||||
|
# leaf - leave it |
||||||
|
} else { |
||||||
|
switch -- $size { |
||||||
|
0 { |
||||||
|
#Debug.trie {optimize empty dict ($t) along '$args'} |
||||||
|
::punk::trie::log::debug {optimize empty dict ($t) along '$args'} |
||||||
|
if {[llength $args]} { |
||||||
|
dict unset trie {*}$args |
||||||
|
} |
||||||
|
} |
||||||
|
1 { |
||||||
|
#Debug.trie {optimize singleton dict ($t) along '$args'} |
||||||
|
::punk::trie::log::debug {optimize singleton dict ($t) along '$args'} |
||||||
|
lassign $t k v |
||||||
|
if {[llength $args]} { |
||||||
|
dict unset trie {*}$args |
||||||
|
} |
||||||
|
append args $k |
||||||
|
if {[llength $v]} { |
||||||
|
dict set trie {*}$args $v |
||||||
|
} |
||||||
|
my optimize {*}$args |
||||||
|
} |
||||||
|
default { |
||||||
|
#Debug.trie {optimize dict ($t) along '$args'} |
||||||
|
::punk::trie::log::debug {optimize dict ($t) along '$args'} |
||||||
|
dict for {k v} $t { |
||||||
|
my optimize {*}$args $k |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# delete element $what from trie |
||||||
|
method delete {what} { |
||||||
|
set path [my find_path $what] |
||||||
|
if {[join $path ""] eq $what} { |
||||||
|
#Debug.trie {del '$what' along ($path) was [dict get $trie {*}$path]} |
||||||
|
if {[catch {dict size [dict get $trie {*}$path]} size]} { |
||||||
|
# got to a matching leaf - delete it |
||||||
|
dict unset trie {*}$path |
||||||
|
set path [lrange $path 0 end-1] |
||||||
|
} else { |
||||||
|
dict unset trie {*}$path "" |
||||||
|
} |
||||||
|
|
||||||
|
my optimize ;# remove empty and singleton elements |
||||||
|
} else { |
||||||
|
# nothing to delete, guess we're done |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# find the value of element $what in trie, |
||||||
|
# error if not found |
||||||
|
method find_or_error {what} { |
||||||
|
set path [my find_path $what] |
||||||
|
if {[join $path ""] eq $what} { |
||||||
|
if {[catch {dict size [dict get $trie {*}$path]} size]} { |
||||||
|
# got to a matching leaf - done |
||||||
|
return [dict get $trie {*}$path] |
||||||
|
} else { |
||||||
|
#JMN - what could be an exact match for a path, but not be in the trie itself |
||||||
|
if {[dict exists $trie {*}$path ""]} { |
||||||
|
return [dict get $trie {*}$path ""] |
||||||
|
} else { |
||||||
|
::punk::trie::log::debug {'$what' matches a path but is not a leaf} |
||||||
|
error "'$what' not found" |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
error "'$what' not found" |
||||||
|
} |
||||||
|
} |
||||||
|
#JMN - renamed original find to find_or_error |
||||||
|
#prefer not to catch on result - but test for -1 |
||||||
|
method find {what} { |
||||||
|
set path [my find_path $what] |
||||||
|
if {[join $path ""] eq $what} { |
||||||
|
#presumably we use catch and dict size to avoid llength shimmering large inner dicts to list rep |
||||||
|
if {[catch {dict size [dict get $trie {*}$path]} size]} { |
||||||
|
# got to a matching leaf - done |
||||||
|
return [dict get $trie {*}$path] |
||||||
|
} else { |
||||||
|
#JMN - what could be an exact match for a path, but not be in the trie itself |
||||||
|
if {[dict exists $trie {*}$path ""]} { |
||||||
|
return [dict get $trie {*}$path ""] |
||||||
|
} else { |
||||||
|
::punk::trie::log::debug {'$what' matches a path but is not a leaf} |
||||||
|
return -1 |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
return -1 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# dump the trie as a string |
||||||
|
method dump {} { |
||||||
|
return $trie |
||||||
|
} |
||||||
|
|
||||||
|
# return a string rep of the trie sorted in dict order |
||||||
|
method order {{t {}}} { |
||||||
|
if {![llength $t]} { |
||||||
|
set t $trie |
||||||
|
} elseif {[llength $t] == 1} { |
||||||
|
return $t |
||||||
|
} |
||||||
|
set acc {} |
||||||
|
|
||||||
|
foreach key [lsort -dictionary [dict keys $t]] { |
||||||
|
lappend acc $key [my order [dict get $t $key]] |
||||||
|
} |
||||||
|
return $acc |
||||||
|
} |
||||||
|
|
||||||
|
# return the trie as a dict of names with values |
||||||
|
method flatten {{t {}} {prefix ""}} { |
||||||
|
if {![llength $t]} { |
||||||
|
set t $trie |
||||||
|
} elseif {[llength $t] == 1} { |
||||||
|
return [list $prefix $t] |
||||||
|
} |
||||||
|
|
||||||
|
set acc {} |
||||||
|
dict for {key val} $t { |
||||||
|
lappend acc {*}[my flatten $val $prefix$key] |
||||||
|
} |
||||||
|
return $acc |
||||||
|
} |
||||||
|
|
||||||
|
#shortest possible string to identify an element in the trie using the same principle as tcl::prefix::match |
||||||
|
#ie if a stored word is a prefix of any other words - it must be fully specified to identify itself. |
||||||
|
#JMN - REVIEW - better algorithms? |
||||||
|
#caller having retained all members can avoid flatten call |
||||||
|
#by selecting a single 'which' known not to be in the trie (or empty string) - all idents can be returned. |
||||||
|
#when all 'which' members are in the tree - scanning stops when they're all found |
||||||
|
# - and a dict containing result and scanned keys is returned |
||||||
|
# - result contains a dict with keys for each which member |
||||||
|
# - scanned contains a dict of all words longer than our shortest which - (and a subset of words the same length) |
||||||
|
method shortest_idents {which {allmembers {}}} { |
||||||
|
set t $trie |
||||||
|
if {![llength $allmembers]} { |
||||||
|
set members [dict keys [my flatten]] |
||||||
|
} else { |
||||||
|
set members $allmembers |
||||||
|
} |
||||||
|
set len_members [lmap m $members {list [string length $m] $m}] |
||||||
|
set longestfirst [lsort -index 0 -integer -decreasing $len_members] |
||||||
|
set longestfirst [lmap v $longestfirst {lindex $v 1}] |
||||||
|
set taken [dict create] |
||||||
|
set scanned [dict create] |
||||||
|
set result [dict create] ;#words in our which list - if found |
||||||
|
foreach w $longestfirst { |
||||||
|
set path [my find_path $w] |
||||||
|
if {[dict exists $taken $w]} { |
||||||
|
#whole word - no unique prefix |
||||||
|
dict set scanned $w $w |
||||||
|
if {$w in $which} { |
||||||
|
#puts stderr "$w -> $w" |
||||||
|
dict set result $w $w |
||||||
|
if {[dict size $result] == [llength $which]} { |
||||||
|
return [dict create result $result scanned $scanned] |
||||||
|
} |
||||||
|
} |
||||||
|
continue |
||||||
|
} |
||||||
|
set acc "" |
||||||
|
foreach p [lrange $path 0 end-1] { |
||||||
|
dict set taken [append acc $p] 1 ;#no need to test first - just set even though may already be present |
||||||
|
} |
||||||
|
append acc [string index [lindex $path end] 0] |
||||||
|
dict set scanned $w $acc ;#sorted by length - so no other can have this prefix - and no longer necessary |
||||||
|
if {$w in $which} { |
||||||
|
#puts stderr "$w -> $acc" |
||||||
|
dict set result $w $acc |
||||||
|
if {[dict size $result] == [llength $which]} { |
||||||
|
return [dict create result $result scanned $scanned] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return [dict create result $result scanned $scanned] |
||||||
|
} |
||||||
|
|
||||||
|
# overwrite the trie |
||||||
|
method set {t} { |
||||||
|
set trie $t |
||||||
|
} |
||||||
|
|
||||||
|
constructor {args} { |
||||||
|
set trie {} |
||||||
|
set id 0 |
||||||
|
foreach a $args { |
||||||
|
my insert $a |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions ---}] |
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
|
||||||
|
set testlist [list blah x black blacken] |
||||||
|
proc test1 {} { |
||||||
|
#JMN |
||||||
|
#test that find_or_error of a path that isn't stored as a value returns an appropriate error |
||||||
|
#(used to report couldn't find dict key "") |
||||||
|
set t [punk::trie::trieclass new blah x black blacken] |
||||||
|
if {[catch {$t find_or_error bla} errM]} { |
||||||
|
puts stderr "should be error indicating 'bla' not found" |
||||||
|
puts stderr "err during $t find bla\n$errM" |
||||||
|
} |
||||||
|
return $t |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#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" |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::trie::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::trie::lib}] |
||||||
|
#[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 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::trie::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval punk::trie::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::trie::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::trie [tcl::namespace::eval punk::trie { |
||||||
|
variable pkg punk::trie |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,237 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::unixywindows 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
#for illegalname_test |
||||||
|
package require punk::winpath |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::unixywindows { |
||||||
|
#'cached' name to make obvious it could be out of date - and to distinguish from unixyroot arg |
||||||
|
variable cachedunixyroot "" |
||||||
|
|
||||||
|
|
||||||
|
#----------------- |
||||||
|
#e.g something like c:/Users/geek/scoop/apps/msys2/current c:/msys2 |
||||||
|
proc get_unixyroot {} { |
||||||
|
variable cachedunixyroot |
||||||
|
if {![string length $cachedunixyroot]} { |
||||||
|
if {![catch { |
||||||
|
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. |
||||||
|
set cachedunixyroot [punk::objclone $result] |
||||||
|
file pathtype $cachedunixyroot; #this call causes the int-rep to be path |
||||||
|
#set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display |
||||||
|
} errM]} { |
||||||
|
|
||||||
|
} else { |
||||||
|
puts stderr "Warning: Failed to determine base for unix-like paths - using default of c:/msys2" |
||||||
|
file pathtype [set cachedunixyroot [punk::objclone "c:/msys2"]] |
||||||
|
} |
||||||
|
} |
||||||
|
#will have been shimmered from string to 'path' internal rep by 'file pathtype' call |
||||||
|
|
||||||
|
#let's return a different copy as it's so easy to lose path-rep |
||||||
|
set copy [punk::objclone $cachedunixyroot] |
||||||
|
return $copy |
||||||
|
} |
||||||
|
proc refresh_unixyroot {} { |
||||||
|
variable cachedunixyroot |
||||||
|
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. |
||||||
|
set cachedunixyroot [punk::objclone $result] |
||||||
|
file pathtype $cachedunixyroot; #this call causes the int-rep to be path |
||||||
|
|
||||||
|
set copy [punk::objclone $cachedunixyroot] |
||||||
|
return $copy |
||||||
|
} |
||||||
|
proc set_unixyroot {windows_path} { |
||||||
|
variable cachedunixyroot |
||||||
|
file pathtype $windows_path |
||||||
|
set cachedunixyroot [punk::objclone $windows_path] |
||||||
|
#return the original - but probably int-rep will have shimmered to path even if started out as string |
||||||
|
#- that's probably what we want. Caller can use as string or path without affecting cachedunixyroot |
||||||
|
return $windows_path |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc windir {path} { |
||||||
|
if {$path eq "~"} { |
||||||
|
#as the tilde hasn't been normalized.. we can't assume we're running on the actual platform |
||||||
|
return ~/.. |
||||||
|
} |
||||||
|
return [file dirname [towinpath $path]] |
||||||
|
} |
||||||
|
|
||||||
|
#REVIEW high-coupling |
||||||
|
proc cdwin {path} { |
||||||
|
set path [towinpath $path] |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
if {[llength [info commands ::punk::console::titleset]]} { |
||||||
|
::punk::console::titleset $path |
||||||
|
} |
||||||
|
} |
||||||
|
cd $path |
||||||
|
} |
||||||
|
proc cdwindir {path} { |
||||||
|
set path [towinpath $path] |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
if {[llength [info commands ::punk::console::titleset]]} { |
||||||
|
::punk::console::titleset $path |
||||||
|
} |
||||||
|
} |
||||||
|
cd [file dirname $path] |
||||||
|
} |
||||||
|
|
||||||
|
#NOTE - this is an expensive operation - avoid where possible. |
||||||
|
#review - is this intended to be useful/callable on non-windows platforms? |
||||||
|
#it should in theory be useable from another platform that wants to create a path for use on windows. |
||||||
|
#In this case - we shouldn't examine what volumes exist (assume A: .. Z: are valid) |
||||||
|
#review zipfs:// other uri schemes? |
||||||
|
proc towinpath {unixypath {unixyroot ""}} { |
||||||
|
#NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative) |
||||||
|
#(Tcl is also somewhat broken as at 2023 as far as volume relative paths - process can get out of sync with tcl if cd to a vol relative path is used) |
||||||
|
#This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD. |
||||||
|
#e.g there is potential confusion when there is a c folder on c: drive (c:/c) |
||||||
|
#I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt |
||||||
|
#whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd. |
||||||
|
#I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong.. |
||||||
|
#It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists |
||||||
|
#This makes it hard to use things like 'file normalize' - which also looks at things like current volume. |
||||||
|
# |
||||||
|
#Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep |
||||||
|
#which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways. |
||||||
|
#The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common |
||||||
|
# |
||||||
|
#convert /c/etc to C:/etc |
||||||
|
set re_slash_x_slash {^/([[:alpha:]]){1}/.*} |
||||||
|
set re_slash_else {^/([[:alpha:]]*)(.*)} |
||||||
|
set volumes [file volumes] |
||||||
|
#exclude things like //zipfs:/ ?? |
||||||
|
set driveletters [list] |
||||||
|
foreach v $volumes { |
||||||
|
if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} { |
||||||
|
lappend driveletters $letter |
||||||
|
} |
||||||
|
} |
||||||
|
#puts stderr "->$driveletters" |
||||||
|
|
||||||
|
set path [punk::objclone $unixypath] ;#take another copy that we can deliberatley shimmer to path and know is separate to the supplied argument |
||||||
|
set supplied_pathtype [file pathtype $path] ;#we don't care about the pathtype so much as the act of making this call shimmers to a path internal-rep |
||||||
|
|
||||||
|
#copy of var that we can treat as a string without affecting path rep |
||||||
|
#Note that some but not all read operations will lose path rep e.g 'string length $x' will lose any path-rep $x had, (but 'string equal $x something' won't) |
||||||
|
#Todo - make int-rep tests to check stability of these behaviours across Tcl versions! |
||||||
|
set strcopy_path [punk::objclone $path] |
||||||
|
|
||||||
|
set str_newpath "" |
||||||
|
|
||||||
|
set have_pathobj 0 |
||||||
|
|
||||||
|
if {[regexp $re_slash_x_slash $strcopy_path _ letter]} { |
||||||
|
#upper case appears to be windows canonical form |
||||||
|
set str_newpath [string toupper $letter]:/[string range $strcopy_path 3 end] |
||||||
|
} elseif {[regexp {^/mnt/([[:alpha:]]){1}/.*} [string tolower $strcopy_path] _ letter]} { |
||||||
|
set str_newpath [string toupper $letter]:/[string range $strcopy_path 7 end] |
||||||
|
} elseif {[regexp {^/mnt/([[:alpha:]]){1}$} [string tolower $strcopy_path] _ letter]} { |
||||||
|
set str_newpath [string toupper $letter]:/ |
||||||
|
} elseif {[regexp $re_slash_else $strcopy_path _ firstpart remainder]} { |
||||||
|
#could be for example /c or /something/users |
||||||
|
if {[string length $firstpart] == 1} { |
||||||
|
set letter $firstpart |
||||||
|
set str_newpath [string toupper $letter]:/ |
||||||
|
} else { |
||||||
|
#according to regex we have a single leading slash |
||||||
|
set str_tail [string range $strcopy_path 1 end] |
||||||
|
if {$unixyroot eq ""} { |
||||||
|
set unixyroot [get_unixyroot] |
||||||
|
} else { |
||||||
|
file pathtype $unixyroot; #side-effect generates int-rep of type path ) |
||||||
|
} |
||||||
|
set pathobj [file join $unixyroot $str_tail] |
||||||
|
file pathtype $pathobj |
||||||
|
set have_pathobj 1 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {!$have_pathobj} { |
||||||
|
if {$str_newpath eq ""} { |
||||||
|
#dunno - pass through |
||||||
|
set pathobj $path |
||||||
|
} else { |
||||||
|
set pathobj [punk::objclone $str_newpath] |
||||||
|
file pathtype $pathobj |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#puts stderr "=> $path" |
||||||
|
#things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder |
||||||
|
# |
||||||
|
#By now file normalize shouldn't do too many shannanigans related to cwd.. |
||||||
|
#We want it to look at cwd for relative paths.. |
||||||
|
#but we don't consider things like /c/Users to be relative even on windows where it would normally mean a volume-relative path e.g c:/c/Users if cwd happens to be somewhere on C: at the time. |
||||||
|
#if {![file exists [file dirname $path]]} { |
||||||
|
# set path [file normalize $path] |
||||||
|
# #may still not exist.. that's ok. |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#file normalize may change backslashes to forward slashes.. including things like the special \\?\ prefix which is intended to stop windows api from parsing a name |
||||||
|
#2023 - this is ok as //?/ also seems to work.. but it is unclear if that is because Tcl is re-converting to backslashes |
||||||
|
if {[punk::winpath::illegalname_test $pathobj]} { |
||||||
|
set pathobj [punk::winpath::illegalname_fix $pathobj] |
||||||
|
} |
||||||
|
|
||||||
|
return $pathobj |
||||||
|
} |
||||||
|
|
||||||
|
#---------------------------------------------- |
||||||
|
#leave the unixywindows related aliases available on all platforms |
||||||
|
#interp alias {} cdwin {} punk::unixywindows::cdwin |
||||||
|
#interp alias {} cdwindir {} punk::unixywindoes::cdwindir |
||||||
|
#interp alias {} towinpath {} punk::unixywindows::towinpath |
||||||
|
#interp alias {} windir {} punk::unixywindows::windir |
||||||
|
#---------------------------------------------- |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::unixywindows [namespace eval punk::unixywindows { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue