136 changed files with 96844 additions and 43154 deletions
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
File diff suppressed because it is too large
Load Diff
@ -1,487 +1,487 @@ |
|||||||
|
|
||||||
tcl::namespace::eval punk::config { |
tcl::namespace::eval punk::config { |
||||||
variable loaded |
variable loaded |
||||||
variable startup ;#include env overrides |
variable startup ;#include env overrides |
||||||
variable running |
variable running |
||||||
variable punk_env_vars |
variable punk_env_vars |
||||||
variable other_env_vars |
variable other_env_vars |
||||||
|
|
||||||
variable vars |
variable vars |
||||||
|
|
||||||
namespace export {[a-z]*} |
namespace export {[a-z]*} |
||||||
|
|
||||||
#todo - XDG_DATA_HOME etc |
#todo - XDG_DATA_HOME etc |
||||||
#https://specifications.freedesktop.org/basedir-spec/latest/ |
#https://specifications.freedesktop.org/basedir-spec/latest/ |
||||||
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ |
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ |
||||||
|
|
||||||
proc init {} { |
proc init {} { |
||||||
variable defaults |
variable defaults |
||||||
variable startup |
variable startup |
||||||
variable running |
variable running |
||||||
variable punk_env_vars |
variable punk_env_vars |
||||||
variable punk_env_vars_config |
variable punk_env_vars_config |
||||||
variable other_env_vars |
variable other_env_vars |
||||||
variable other_env_vars_config |
variable other_env_vars_config |
||||||
|
|
||||||
set exename "" |
set exename "" |
||||||
catch { |
catch { |
||||||
#catch for safe interps |
#catch for safe interps |
||||||
#safe base will return empty string, ordinary safe interp will raise error |
#safe base will return empty string, ordinary safe interp will raise error |
||||||
set exename [tcl::info::nameofexecutable] |
set exename [tcl::info::nameofexecutable] |
||||||
} |
} |
||||||
if {$exename ne ""} { |
if {$exename ne ""} { |
||||||
set exefolder [file dirname $exename] |
set exefolder [file dirname $exename] |
||||||
#default file logs to logs folder at same level as exe if writable, or empty string |
#default file logs to logs folder at same level as exe if writable, or empty string |
||||||
set log_folder [file normalize $exefolder/../logs] ;#~2ms |
set log_folder [file normalize $exefolder/../logs] ;#~2ms |
||||||
#tcl::dict::set startup scriptlib $exefolder/scriptlib |
#tcl::dict::set startup scriptlib $exefolder/scriptlib |
||||||
#tcl::dict::set startup apps $exefolder/../../punkapps |
#tcl::dict::set startup apps $exefolder/../../punkapps |
||||||
|
|
||||||
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc |
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc |
||||||
set default_scriptlib $exefolder/scriptlib |
set default_scriptlib $exefolder/scriptlib |
||||||
set default_apps $exefolder/../../punkapps |
set default_apps $exefolder/../../punkapps |
||||||
if {[file isdirectory $log_folder] && [file writable $log_folder]} { |
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_stdout $log_folder/repl-exec-stdout.txt |
||||||
#tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.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_stdout $log_folder/repl-exec-stdout.txt |
||||||
set default_logfile_stderr $log_folder/repl-exec-stderr.txt |
set default_logfile_stderr $log_folder/repl-exec-stderr.txt |
||||||
} else { |
} else { |
||||||
set default_logfile_stdout "" |
set default_logfile_stdout "" |
||||||
set default_logfile_stderr "" |
set default_logfile_stderr "" |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island |
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island |
||||||
#review - todo? |
#review - todo? |
||||||
#tcl::dict::set startup scriptlib "" |
#tcl::dict::set startup scriptlib "" |
||||||
#tcl::dict::set startup apps "" |
#tcl::dict::set startup apps "" |
||||||
set default_scriptlib "" |
set default_scriptlib "" |
||||||
set default_apps "" |
set default_apps "" |
||||||
set default_logfile_stdout "" |
set default_logfile_stdout "" |
||||||
set default_logfile_stderr "" |
set default_logfile_stderr "" |
||||||
} |
} |
||||||
|
|
||||||
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run |
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run |
||||||
|
|
||||||
#optional channel transforms on stdout/stderr. |
#optional channel transforms on stdout/stderr. |
||||||
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands |
#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> |
#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. |
#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 |
#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 brightwhite ;#stdout colour including background calls (after etc) |
||||||
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only |
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. |
#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 "red bold" |
||||||
#set default_color_stderr "web-lightsalmon" |
#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 yellow ;#limit to basic colours for wider terminal support. yellow = term-olive |
||||||
set default_color_stderr_repl "" ;#during repl call only |
set default_color_stderr_repl "" ;#during repl call only |
||||||
|
|
||||||
set homedir "" |
set homedir "" |
||||||
if {[catch { |
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 |
#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 |
#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] |
set homedir [file home] |
||||||
} errM]} { |
} errM]} { |
||||||
#tcl 8.6 doesn't have file home.. try again |
#tcl 8.6 doesn't have file home.. try again |
||||||
if {[info exists ::env(HOME)]} { |
if {[info exists ::env(HOME)]} { |
||||||
set homedir $::env(HOME) |
set homedir $::env(HOME) |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
|
|
||||||
# per user xdg vars |
# per user xdg vars |
||||||
# --- |
# --- |
||||||
set default_xdg_config_home "" ;#config data - portable |
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_data_home "" ;#data the user likely to want to be portable |
||||||
set default_xdg_cache_home "" ;#local cache |
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_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 |
set default_xdg_data_dirs "" ;#non-user specific |
||||||
#xdg_config_dirs ? |
#xdg_config_dirs ? |
||||||
#xdg_runtime_dir ? |
#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) |
#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) |
#(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. |
#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 {$homedir ne ""} { |
||||||
if {"windows" eq $::tcl_platform(platform)} { |
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. |
#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) |
#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. |
#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)]} { |
if {[info exists ::env(APPDATA)]} { |
||||||
set default_xdg_config_home $::env(APPDATA) |
set default_xdg_config_home $::env(APPDATA) |
||||||
set default_xdg_data_home $::env(APPDATA) |
set default_xdg_data_home $::env(APPDATA) |
||||||
} |
} |
||||||
|
|
||||||
#The xdg_cache_home should be kept local |
#The xdg_cache_home should be kept local |
||||||
if {[info exists ::env(LOCALAPPDATA)]} { |
if {[info exists ::env(LOCALAPPDATA)]} { |
||||||
set default_xdg_cache_home $::env(LOCALAPPDATA) |
set default_xdg_cache_home $::env(LOCALAPPDATA) |
||||||
set default_xdg_state_home $::env(LOCALAPPDATA) |
set default_xdg_state_home $::env(LOCALAPPDATA) |
||||||
} |
} |
||||||
|
|
||||||
if {[info exists ::env(PROGRAMDATA)]} { |
if {[info exists ::env(PROGRAMDATA)]} { |
||||||
#- equiv env(ALLUSERSPROFILE) ? |
#- equiv env(ALLUSERSPROFILE) ? |
||||||
set default_xdg_data_dirs $::env(PROGRAMDATA) |
set default_xdg_data_dirs $::env(PROGRAMDATA) |
||||||
} |
} |
||||||
|
|
||||||
} else { |
} else { |
||||||
#follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html |
#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_config_home [file join $homedir .config] |
||||||
set default_xdg_data_home [file join $homedir .local share] |
set default_xdg_data_home [file join $homedir .local share] |
||||||
set default_xdg_cache_home [file join $homedir .cache] |
set default_xdg_cache_home [file join $homedir .cache] |
||||||
set default_xdg_state_home [file join $homedir .local state] |
set default_xdg_state_home [file join $homedir .local state] |
||||||
set default_xdg_data_dirs /usr/local/share |
set default_xdg_data_dirs /usr/local/share |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
set defaults [dict create\ |
set defaults [dict create\ |
||||||
apps $default_apps\ |
apps $default_apps\ |
||||||
config ""\ |
config ""\ |
||||||
configset ".punkshell"\ |
configset ".punkshell"\ |
||||||
scriptlib $default_scriptlib\ |
scriptlib $default_scriptlib\ |
||||||
color_stdout $default_color_stdout\ |
color_stdout $default_color_stdout\ |
||||||
color_stdout_repl $default_color_stdout_repl\ |
color_stdout_repl $default_color_stdout_repl\ |
||||||
color_stderr $default_color_stderr\ |
color_stderr $default_color_stderr\ |
||||||
color_stderr_repl $default_color_stderr_repl\ |
color_stderr_repl $default_color_stderr_repl\ |
||||||
logfile_stdout $default_logfile_stdout\ |
logfile_stdout $default_logfile_stdout\ |
||||||
logfile_stderr $default_logfile_stderr\ |
logfile_stderr $default_logfile_stderr\ |
||||||
logfile_active 0\ |
logfile_active 0\ |
||||||
syslog_stdout "127.0.0.1:514"\ |
syslog_stdout "127.0.0.1:514"\ |
||||||
syslog_stderr "127.0.0.1:514"\ |
syslog_stderr "127.0.0.1:514"\ |
||||||
syslog_active 0\ |
syslog_active 0\ |
||||||
auto_exec_mechanism exec\ |
auto_exec_mechanism exec\ |
||||||
auto_noexec 0\ |
auto_noexec 0\ |
||||||
xdg_config_home $default_xdg_config_home\ |
xdg_config_home $default_xdg_config_home\ |
||||||
xdg_data_home $default_xdg_data_home\ |
xdg_data_home $default_xdg_data_home\ |
||||||
xdg_cache_home $default_xdg_cache_home\ |
xdg_cache_home $default_xdg_cache_home\ |
||||||
xdg_state_home $default_xdg_state_home\ |
xdg_state_home $default_xdg_state_home\ |
||||||
xdg_data_dirs $default_xdg_data_dirs\ |
xdg_data_dirs $default_xdg_data_dirs\ |
||||||
theme_posh_override ""\ |
theme_posh_override ""\ |
||||||
posh_theme ""\ |
posh_theme ""\ |
||||||
posh_themes_path ""\ |
posh_themes_path ""\ |
||||||
] |
] |
||||||
|
|
||||||
set startup $defaults |
set startup $defaults |
||||||
#load values from saved config file - $xdg_config_home/punk/punk.config ? |
#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. |
#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 |
#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? |
#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? |
#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 |
#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? |
#- 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. |
#we are likely to want the saved configs for subshells/decks to override them however. |
||||||
|
|
||||||
#todo - load/save config file |
#todo - load/save config file |
||||||
|
|
||||||
#todo - define which configvars are settable in env |
#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) |
#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 \ |
set punk_env_vars_config [dict create \ |
||||||
PUNK_APPS {type pathlist}\ |
PUNK_APPS {type pathlist}\ |
||||||
PUNK_CONFIG {type string}\ |
PUNK_CONFIG {type string}\ |
||||||
PUNK_CONFIGSET {type string}\ |
PUNK_CONFIGSET {type string}\ |
||||||
PUNK_SCRIPTLIB {type string}\ |
PUNK_SCRIPTLIB {type string}\ |
||||||
PUNK_AUTO_EXEC_MECHANISM {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_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 {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_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 {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_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ |
||||||
PUNK_LOGFILE_STDOUT {type string}\ |
PUNK_LOGFILE_STDOUT {type string}\ |
||||||
PUNK_LOGFILE_STDERR {type string}\ |
PUNK_LOGFILE_STDERR {type string}\ |
||||||
PUNK_LOGFILE_ACTIVE {type string}\ |
PUNK_LOGFILE_ACTIVE {type string}\ |
||||||
PUNK_SYSLOG_STDOUT {type string}\ |
PUNK_SYSLOG_STDOUT {type string}\ |
||||||
PUNK_SYSLOG_STDERR {type string}\ |
PUNK_SYSLOG_STDERR {type string}\ |
||||||
PUNK_SYSLOG_ACTIVE {type string}\ |
PUNK_SYSLOG_ACTIVE {type string}\ |
||||||
PUNK_THEME_POSH_OVERRIDE {type string}\ |
PUNK_THEME_POSH_OVERRIDE {type string}\ |
||||||
] |
] |
||||||
set punk_env_vars [dict keys $punk_env_vars_config] |
set punk_env_vars [dict keys $punk_env_vars_config] |
||||||
|
|
||||||
#override with env vars if set |
#override with env vars if set |
||||||
foreach {evar varinfo} $punk_env_vars_config { |
foreach {evar varinfo} $punk_env_vars_config { |
||||||
if {[info exists ::env($evar)]} { |
if {[info exists ::env($evar)]} { |
||||||
set vartype [dict get $varinfo type] |
set vartype [dict get $varinfo type] |
||||||
set f [set ::env($evar)] |
set f [set ::env($evar)] |
||||||
if {$f ne "default"} { |
if {$f ne "default"} { |
||||||
#e.g PUNK_SCRIPTLIB -> scriptlib |
#e.g PUNK_SCRIPTLIB -> scriptlib |
||||||
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] |
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] |
||||||
if {$vartype eq "pathlist"} { |
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 |
#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. |
#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. |
#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. |
#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 |
#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. |
# - 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 paths [split $f $::tcl_platform(pathSeparator)] |
||||||
set final [list] |
set final [list] |
||||||
#eliminate empty values (leading or trailing or extraneous separators) |
#eliminate empty values (leading or trailing or extraneous separators) |
||||||
foreach p $paths { |
foreach p $paths { |
||||||
if {[tcl::string::trim $p] ne ""} { |
if {[tcl::string::trim $p] ne ""} { |
||||||
lappend final $p |
lappend final $p |
||||||
} |
} |
||||||
} |
} |
||||||
tcl::dict::set startup $varname $final |
tcl::dict::set startup $varname $final |
||||||
} else { |
} else { |
||||||
tcl::dict::set startup $varname $f |
tcl::dict::set startup $varname $f |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
# https://no-color.org |
# https://no-color.org |
||||||
#if {[info exists ::env(NO_COLOR)]} { |
#if {[info exists ::env(NO_COLOR)]} { |
||||||
# if {$::env(NO_COLOR) ne ""} { |
# if {$::env(NO_COLOR) ne ""} { |
||||||
# set colour_disabled 1 |
# set colour_disabled 1 |
||||||
# } |
# } |
||||||
#} |
#} |
||||||
set other_env_vars_config [dict create\ |
set other_env_vars_config [dict create\ |
||||||
NO_COLOR {type string}\ |
NO_COLOR {type string}\ |
||||||
XDG_CONFIG_HOME {type string}\ |
XDG_CONFIG_HOME {type string}\ |
||||||
XDG_DATA_HOME {type string}\ |
XDG_DATA_HOME {type string}\ |
||||||
XDG_CACHE_HOME {type string}\ |
XDG_CACHE_HOME {type string}\ |
||||||
XDG_STATE_HOME {type string}\ |
XDG_STATE_HOME {type string}\ |
||||||
XDG_DATA_DIRS {type pathlist}\ |
XDG_DATA_DIRS {type pathlist}\ |
||||||
POSH_THEME {type string}\ |
POSH_THEME {type string}\ |
||||||
POSH_THEMES_PATH {type string}\ |
POSH_THEMES_PATH {type string}\ |
||||||
TCLLIBPATH {type string}\ |
TCLLIBPATH {type string}\ |
||||||
] |
] |
||||||
lassign [split [info tclversion] .] tclmajorv tclminorv |
lassign [split [info tclversion] .] tclmajorv tclminorv |
||||||
#don't rely on lseq or punk::lib for now.. |
#don't rely on lseq or punk::lib for now.. |
||||||
set relevant_minors [list] |
set relevant_minors [list] |
||||||
for {set i 0} {$i <= $tclminorv} {incr i} { |
for {set i 0} {$i <= $tclminorv} {incr i} { |
||||||
lappend relevant_minors $i |
lappend relevant_minors $i |
||||||
} |
} |
||||||
foreach minor $relevant_minors { |
foreach minor $relevant_minors { |
||||||
set vname TCL${tclmajorv}_${minor}_TM_PATH |
set vname TCL${tclmajorv}_${minor}_TM_PATH |
||||||
if {$minor eq $tclminorv || [info exists ::env($vname)]} { |
if {$minor eq $tclminorv || [info exists ::env($vname)]} { |
||||||
dict set other_env_vars_config $vname {type string} |
dict set other_env_vars_config $vname {type string} |
||||||
} |
} |
||||||
} |
} |
||||||
set other_env_vars [dict keys $other_env_vars_config] |
set other_env_vars [dict keys $other_env_vars_config] |
||||||
|
|
||||||
foreach {evar varinfo} $other_env_vars_config { |
foreach {evar varinfo} $other_env_vars_config { |
||||||
if {[info exists ::env($evar)]} { |
if {[info exists ::env($evar)]} { |
||||||
set vartype [dict get $varinfo type] |
set vartype [dict get $varinfo type] |
||||||
set f [set ::env($evar)] |
set f [set ::env($evar)] |
||||||
if {$f ne "default"} { |
if {$f ne "default"} { |
||||||
set varname [tcl::string::tolower $evar] |
set varname [tcl::string::tolower $evar] |
||||||
if {$vartype eq "pathlist"} { |
if {$vartype eq "pathlist"} { |
||||||
set paths [split $f $::tcl_platform(pathSeparator)] |
set paths [split $f $::tcl_platform(pathSeparator)] |
||||||
set final [list] |
set final [list] |
||||||
#eliminate empty values (leading or trailing or extraneous separators) |
#eliminate empty values (leading or trailing or extraneous separators) |
||||||
foreach p $paths { |
foreach p $paths { |
||||||
if {[tcl::string::trim $p] ne ""} { |
if {[tcl::string::trim $p] ne ""} { |
||||||
lappend final $p |
lappend final $p |
||||||
} |
} |
||||||
} |
} |
||||||
tcl::dict::set startup $varname $final |
tcl::dict::set startup $varname $final |
||||||
} else { |
} else { |
||||||
tcl::dict::set startup $varname $f |
tcl::dict::set startup $varname $f |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
|
|
||||||
#unset -nocomplain vars |
#unset -nocomplain vars |
||||||
|
|
||||||
#todo |
#todo |
||||||
set running [tcl::dict::create] |
set running [tcl::dict::create] |
||||||
set running [tcl::dict::merge $running $startup] |
set running [tcl::dict::merge $running $startup] |
||||||
} |
} |
||||||
init |
init |
||||||
|
|
||||||
#todo |
#todo |
||||||
proc Apply {config} { |
proc Apply {config} { |
||||||
puts stderr "punk::config::Apply partially implemented" |
puts stderr "punk::config::Apply partially implemented" |
||||||
set configname [string map {-config ""} $config] |
set configname [string map {-config ""} $config] |
||||||
if {$configname in {startup running}} { |
if {$configname in {startup running}} { |
||||||
upvar ::punk::config::$configname applyconfig |
upvar ::punk::config::$configname applyconfig |
||||||
|
|
||||||
if {[dict exists $applyconfig auto_noexec]} { |
if {[dict exists $applyconfig auto_noexec]} { |
||||||
set auto [dict get $applyconfig auto_noexec] |
set auto [dict get $applyconfig auto_noexec] |
||||||
if {![string is boolean -strict $auto]} { |
if {![string is boolean -strict $auto]} { |
||||||
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" |
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" |
||||||
} |
} |
||||||
if {$auto} { |
if {$auto} { |
||||||
set ::auto_noexec 1 |
set ::auto_noexec 1 |
||||||
} else { |
} else { |
||||||
#puts "auto_noexec false" |
#puts "auto_noexec false" |
||||||
unset -nocomplain ::auto_noexec |
unset -nocomplain ::auto_noexec |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
} else { |
} else { |
||||||
error "no config named '$config' found" |
error "no config named '$config' found" |
||||||
} |
} |
||||||
return "apply done" |
return "apply done" |
||||||
} |
} |
||||||
Apply startup |
Apply startup |
||||||
|
|
||||||
#todo - consider how to divide up settings, categories, 'devices', decks etc |
#todo - consider how to divide up settings, categories, 'devices', decks etc |
||||||
proc get_running_global {varname} { |
proc get_running_global {varname} { |
||||||
variable running |
variable running |
||||||
if {[dict exists $running $varname]} { |
if {[dict exists $running $varname]} { |
||||||
return [dict get $running $varname] |
return [dict get $running $varname] |
||||||
} |
} |
||||||
error "No such global configuration item '$varname' found in running config" |
error "No such global configuration item '$varname' found in running config" |
||||||
} |
} |
||||||
proc get_startup_global {varname} { |
proc get_startup_global {varname} { |
||||||
variable startup |
variable startup |
||||||
if {[dict exists $startup $varname]} { |
if {[dict exists $startup $varname]} { |
||||||
return [dict get $startup $varname] |
return [dict get $startup $varname] |
||||||
} |
} |
||||||
error "No such global configuration item '$varname' found in startup config" |
error "No such global configuration item '$varname' found in startup config" |
||||||
} |
} |
||||||
|
|
||||||
proc get {whichconfig {globfor *}} { |
proc get {whichconfig {globfor *}} { |
||||||
variable startup |
variable startup |
||||||
variable running |
variable running |
||||||
switch -- $whichconfig { |
switch -- $whichconfig { |
||||||
config - startup - startup-config - startup-configuration { |
config - startup - startup-config - startup-configuration { |
||||||
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs |
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs |
||||||
set configdata $startup |
set configdata $startup |
||||||
} |
} |
||||||
running - running-config - running-configuration { |
running - running-config - running-configuration { |
||||||
set configdata $running |
set configdata $running |
||||||
} |
} |
||||||
default { |
default { |
||||||
error "Unknown config name '$whichconfig' - try startup or running" |
error "Unknown config name '$whichconfig' - try startup or running" |
||||||
} |
} |
||||||
} |
} |
||||||
if {$globfor eq "*"} { |
if {$globfor eq "*"} { |
||||||
return $configdata |
return $configdata |
||||||
} else { |
} else { |
||||||
set keys [dict keys $configdata [string tolower $globfor]] |
set keys [dict keys $configdata [string tolower $globfor]] |
||||||
set filtered [dict create] |
set filtered [dict create] |
||||||
foreach k $keys { |
foreach k $keys { |
||||||
dict set filtered $k [dict get $configdata $k] |
dict set filtered $k [dict get $configdata $k] |
||||||
} |
} |
||||||
return $filtered |
return $filtered |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
proc configure {args} { |
proc configure {args} { |
||||||
set argdef { |
set argdef { |
||||||
@id -id ::punk::config::configure |
@id -id ::punk::config::configure |
||||||
@cmd -name punk::config::configure -help\ |
@cmd -name punk::config::configure -help\ |
||||||
"UNIMPLEMENTED" |
"UNIMPLEMENTED" |
||||||
@values -min 1 -max 1 |
@values -min 1 -max 1 |
||||||
whichconfig -type string -choices {startup running stop} |
whichconfig -type string -choices {startup running stop} |
||||||
} |
} |
||||||
set argd [punk::args::get_dict $argdef $args] |
set argd [punk::args::get_dict $argdef $args] |
||||||
return "unimplemented - $argd" |
return "unimplemented - $argd" |
||||||
} |
} |
||||||
|
|
||||||
proc show {whichconfig {globfor *}} { |
proc show {whichconfig {globfor *}} { |
||||||
#todo - tables for console |
#todo - tables for console |
||||||
set configdata [punk::config::get $whichconfig $globfor] |
set configdata [punk::config::get $whichconfig $globfor] |
||||||
return [punk::lib::showdict $configdata] |
return [punk::lib::showdict $configdata] |
||||||
} |
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#e.g |
#e.g |
||||||
# copy running-config startup-config |
# copy running-config startup-config |
||||||
# copy startup-config test-config.cfg |
# copy startup-config test-config.cfg |
||||||
# copy backup-config.cfg running-config |
# 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 |
#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 |
#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} { |
proc copy {args} { |
||||||
set argdef { |
set argdef { |
||||||
@id -id ::punk::config::copy |
@id -id ::punk::config::copy |
||||||
@cmd -name punk::config::copy -help\ |
@cmd -name punk::config::copy -help\ |
||||||
"Copy a partial or full configuration from one config to another |
"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. |
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\ |
-type -default "" -choices {replace merge} -help\ |
||||||
"Defaults to merge when target is running-config |
"Defaults to merge when target is running-config |
||||||
Defaults to replace when source is running-config" |
Defaults to replace when source is running-config" |
||||||
@values -min 2 -max 2 |
@values -min 2 -max 2 |
||||||
fromconfig -help\ |
fromconfig -help\ |
||||||
"running or startup or file name (not fully implemented)" |
"running or startup or file name (not fully implemented)" |
||||||
toconfig -help\ |
toconfig -help\ |
||||||
"running or startup or file name (not fully implemented)" |
"running or startup or file name (not fully implemented)" |
||||||
} |
} |
||||||
set argd [punk::args::get_dict $argdef $args] |
set argd [punk::args::get_dict $argdef $args] |
||||||
set fromconfig [dict get $argd values fromconfig] |
set fromconfig [dict get $argd values fromconfig] |
||||||
set toconfig [dict get $argd values toconfig] |
set toconfig [dict get $argd values toconfig] |
||||||
set fromconfig [string map {-config ""} $fromconfig] |
set fromconfig [string map {-config ""} $fromconfig] |
||||||
set toconfig [string map {-config ""} $toconfig] |
set toconfig [string map {-config ""} $toconfig] |
||||||
|
|
||||||
set copytype [dict get $argd opts -type] |
set copytype [dict get $argd opts -type] |
||||||
|
|
||||||
|
|
||||||
#todo - warn & prompt if doing merge copy to startup |
#todo - warn & prompt if doing merge copy to startup |
||||||
switch -exact -- $fromconfig-$toconfig { |
switch -exact -- $fromconfig-$toconfig { |
||||||
running-startup { |
running-startup { |
||||||
if {$copytype eq ""} { |
if {$copytype eq ""} { |
||||||
set copytype replace ;#full configuration |
set copytype replace ;#full configuration |
||||||
} |
} |
||||||
if {$copytype eq "replace"} { |
if {$copytype eq "replace"} { |
||||||
error "punk::config::copy error. full configuration copy from running to startup config not yet supported" |
error "punk::config::copy error. full configuration copy from running to startup config not yet supported" |
||||||
} else { |
} else { |
||||||
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" |
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" |
||||||
} |
} |
||||||
} |
} |
||||||
startup-running { |
startup-running { |
||||||
#default type merge - even though it's not always what is desired |
#default type merge - even though it's not always what is desired |
||||||
if {$copytype eq ""} { |
if {$copytype eq ""} { |
||||||
set copytype merge ;#load in a partial configuration |
set copytype merge ;#load in a partial configuration |
||||||
} |
} |
||||||
|
|
||||||
#warn/prompt either way |
#warn/prompt either way |
||||||
if {$copytype eq "replace"} { |
if {$copytype eq "replace"} { |
||||||
#some routers require use of a separate command for this branch. |
#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 |
#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" |
error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" |
||||||
} else { |
} else { |
||||||
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" |
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" |
||||||
} |
} |
||||||
} |
} |
||||||
default { |
default { |
||||||
error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" |
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? |
#todo - move to cli? |
||||||
::tcl::namespace::eval punk::config { |
::tcl::namespace::eval punk::config { |
||||||
#todo - something better - 'previous' rather than reverting to startup |
#todo - something better - 'previous' rather than reverting to startup |
||||||
proc channelcolors {{onoff {}}} { |
proc channelcolors {{onoff {}}} { |
||||||
variable running |
variable running |
||||||
variable startup |
variable startup |
||||||
|
|
||||||
if {![string length $onoff]} { |
if {![string length $onoff]} { |
||||||
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
||||||
} else { |
} else { |
||||||
if {![string is boolean $onoff]} { |
if {![string is boolean $onoff]} { |
||||||
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" |
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" |
||||||
} |
} |
||||||
if {$onoff} { |
if {$onoff} { |
||||||
dict set running color_stdout [dict get $startup color_stdout] |
dict set running color_stdout [dict get $startup color_stdout] |
||||||
dict set running color_stderr [dict get $startup color_stderr] |
dict set running color_stderr [dict get $startup color_stderr] |
||||||
} else { |
} else { |
||||||
dict set running color_stdout "" |
dict set running color_stdout "" |
||||||
dict set running color_stderr "" |
dict set running color_stderr "" |
||||||
} |
} |
||||||
} |
} |
||||||
return [list stdout [dict get $running color_stdout] stderr [dict get $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 { |
package provide punk::config [tcl::namespace::eval punk::config { |
||||||
variable version |
variable version |
||||||
set version 0.1 |
set version 0.1 |
||||||
|
|
||||||
}] |
}] |
||||||
@ -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'" |
|
||||||
|
|
||||||
@ -1,164 +1,163 @@ |
|||||||
#punkapps app manager |
#punkapps app manager |
||||||
# deck cli |
# deck cli |
||||||
|
|
||||||
namespace eval punk::mod::cli { |
namespace eval punk::mod::cli { |
||||||
namespace export help list run |
namespace export help list run |
||||||
namespace ensemble create |
namespace ensemble create |
||||||
|
|
||||||
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown |
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown |
||||||
if 0 { |
if 0 { |
||||||
proc _unknown {ns args} { |
proc _unknown {ns args} { |
||||||
puts stderr "punk::mod::cli::_unknown '$ns' '$args'" |
puts stderr "punk::mod::cli::_unknown '$ns' '$args'" |
||||||
puts stderr "punk::mod::cli::help $args" |
puts stderr "punk::mod::cli::help $args" |
||||||
puts stderr "arglen:[llength $args]" |
puts stderr "arglen:[llength $args]" |
||||||
punk::mod::cli::help {*}$args |
punk::mod::cli::help {*}$args |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
#cli must have _init method - usually used to load commandsets lazily |
#cli must have _init method - usually used to load commandsets lazily |
||||||
# |
# |
||||||
variable initialised 0 |
variable initialised 0 |
||||||
proc _init {args} { |
proc _init {args} { |
||||||
variable initialised |
variable initialised |
||||||
if {$initialised} { |
if {$initialised} { |
||||||
return |
return |
||||||
} |
} |
||||||
#... |
#... |
||||||
set initialised 1 |
set initialised 1 |
||||||
} |
} |
||||||
|
|
||||||
proc help {args} { |
proc help {args} { |
||||||
set basehelp [punk::mix::base help {*}$args] |
set basehelp [punk::mix::base help {*}$args] |
||||||
#namespace export |
#namespace export |
||||||
return $basehelp |
return $basehelp |
||||||
} |
} |
||||||
proc getraw {appname} { |
proc getraw {appname} { |
||||||
upvar ::punk::config::running running_config |
upvar ::punk::config::running running_config |
||||||
set app_folders [dict get $running_config apps] |
set app_folders [dict get $running_config apps] |
||||||
#todo search each app folder |
#todo search each app folder |
||||||
set bases [::list] |
set bases [::list] |
||||||
set versions [::list] |
set versions [::list] |
||||||
set mains [::list] |
set mains [::list] |
||||||
set appinfo [::list bases {} mains {} versions {}] |
set appinfo [::list bases {} mains {} versions {}] |
||||||
|
|
||||||
foreach containerfolder $app_folders { |
foreach containerfolder $app_folders { |
||||||
lappend bases $containerfolder |
lappend bases $containerfolder |
||||||
if {[file exists $containerfolder]} { |
if {[file exists $containerfolder]} { |
||||||
if {[file exists $containerfolder/$appname/main.tcl]} { |
if {[file exists $containerfolder/$appname/main.tcl]} { |
||||||
#exact match - only return info for the exact one specified |
#exact match - only return info for the exact one specified |
||||||
set namematches $appname |
set namematches $appname |
||||||
set parts [split $appname -] |
set parts [split $appname -] |
||||||
} else { |
} else { |
||||||
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] |
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] |
||||||
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||||
} |
} |
||||||
foreach nm $namematches { |
foreach nm $namematches { |
||||||
set mainfile $containerfolder/$nm/main.tcl |
set mainfile $containerfolder/$nm/main.tcl |
||||||
set parts [split $nm -] |
set parts [split $nm -] |
||||||
if {[llength $parts] == 1} { |
if {[llength $parts] == 1} { |
||||||
set ver "" |
set ver "" |
||||||
} else { |
} else { |
||||||
set ver [lindex $parts end] |
set ver [lindex $parts end] |
||||||
} |
} |
||||||
if {$ver ni $versions} { |
if {$ver ni $versions} { |
||||||
lappend versions $ver |
lappend versions $ver |
||||||
lappend mains $ver $mainfile |
lappend mains $ver $mainfile |
||||||
} else { |
} 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)" |
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 { |
} else { |
||||||
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" |
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" |
||||||
} |
} |
||||||
} |
} |
||||||
dict set appinfo versions $versions |
dict set appinfo versions $versions |
||||||
#todo - natsort! |
#todo - natsort! |
||||||
set sorted_versions [lsort $versions] |
set sorted_versions [lsort $versions] |
||||||
set latest [lindex $sorted_versions 0] |
set latest [lindex $sorted_versions 0] |
||||||
if {$latest eq "" && [llength $sorted_versions] > 1} { |
if {$latest eq "" && [llength $sorted_versions] > 1} { |
||||||
set latest [lindex $sorted_versions 1 |
set latest [lindex $sorted_versions 1] |
||||||
} |
} |
||||||
dict set appinfo latest $latest |
dict set appinfo latest $latest |
||||||
|
|
||||||
dict set appinfo bases $bases |
dict set appinfo bases $bases |
||||||
dict set appinfo mains $mains |
dict set appinfo mains $mains |
||||||
return $appinfo |
return $appinfo |
||||||
} |
} |
||||||
|
|
||||||
proc list {{glob *}} { |
proc list {{glob *}} { |
||||||
upvar ::punk::config::running running_config |
upvar ::punk::config::running running_config |
||||||
set apps_folder [dict get $running_config apps] |
set apps_folder [dict get $running_config apps] |
||||||
if {[file exists $apps_folder]} { |
if {[file exists $apps_folder]} { |
||||||
if {[file exists $apps_folder/$glob]} { |
if {[file exists $apps_folder/$glob]} { |
||||||
#tailcall source $apps_folder/$glob/main.tcl |
#tailcall source $apps_folder/$glob/main.tcl |
||||||
return $glob |
return $glob |
||||||
} |
} |
||||||
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] |
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] |
||||||
if {[llength $apps] == 0} { |
if {[llength $apps] == 0} { |
||||||
if {[string first * $glob] <0 && [string first ? $glob] <0} { |
if {[string first * $glob] <0 && [string first ? $glob] <0} { |
||||||
#no glob chars supplied - only launch if exact match for name part |
#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 [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] |
||||||
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||||
if {[llength $namematches] > 0} { |
if {[llength $namematches] > 0} { |
||||||
set latest [lindex $namematches end] |
set latest [lindex $namematches end] |
||||||
lassign $latest nm ver |
lassign $latest nm ver |
||||||
#tailcall source $apps_folder/$latest/main.tcl |
#tailcall source $apps_folder/$latest/main.tcl |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
return $apps |
return $apps |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
#todo - way to launch as separate process |
#todo - way to launch as separate process |
||||||
# solo-opts only before appname - args following appname are passed to the app |
# solo-opts only before appname - args following appname are passed to the app |
||||||
proc run {args} { |
proc run {args} { |
||||||
set nameposn [lsearch -not $args -*] |
set nameposn [lsearch -not $args -*] |
||||||
if {$nameposn < 0} { |
if {$nameposn < 0} { |
||||||
error "punkapp::run unable to determine application name" |
error "punkapp::run unable to determine application name" |
||||||
} |
} |
||||||
set appname [lindex $args $nameposn] |
set appname [lindex $args $nameposn] |
||||||
set controlargs [lrange $args 0 $nameposn-1] |
set controlargs [lrange $args 0 $nameposn-1] |
||||||
set appargs [lrange $args $nameposn+1 end] |
set appargs [lrange $args $nameposn+1 end] |
||||||
|
|
||||||
set appinfo [punk::mod::cli::getraw $appname] |
set appinfo [punk::mod::cli::getraw $appname] |
||||||
if {[llength [dict get $appinfo versions]]} { |
if {[llength [dict get $appinfo versions]]} { |
||||||
set ver [dict get $appinfo latest] |
set ver [dict get $appinfo latest] |
||||||
puts stdout "info: $appinfo" |
puts stdout "info: $appinfo" |
||||||
set ::argc [llength $appargs] |
set ::argc [llength $appargs] |
||||||
set ::argv $appargs |
set ::argv $appargs |
||||||
source [dict get $appinfo mains $ver] |
source [dict get $appinfo mains $ver] |
||||||
if {"-hideconsole" in $controlargs} { |
if {"-hideconsole" in $controlargs} { |
||||||
puts stderr "attempting console hide" |
puts stderr "attempting console hide" |
||||||
#todo - something better - a callback when window mapped? |
#todo - something better - a callback when window mapped? |
||||||
after 500 {::punkapp::hide_console} |
after 500 {::punkapp::hide_console} |
||||||
} |
} |
||||||
return $appinfo |
return $appinfo |
||||||
} else { |
} else { |
||||||
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" |
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
|
|
||||||
} |
} |
||||||
|
|
||||||
namespace eval punk::mod::cli { |
namespace eval punk::mod::cli { |
||||||
proc _cli {args} { |
proc _cli {args} { |
||||||
#don't use tailcall - base uses info level to determine caller |
#don't use tailcall - base uses info level to determine caller |
||||||
::punk::mix::base::_cli {*}$args |
::punk::mix::base::_cli {*}$args |
||||||
} |
} |
||||||
variable default_command help |
variable default_command help |
||||||
package require punk::mix::base |
package require punk::mix::base |
||||||
package require punk::overlay |
package require punk::overlay |
||||||
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||||
} |
} |
||||||
|
|
||||||
package provide punk::mod [namespace eval punk::mod { |
package provide punk::mod [namespace eval punk::mod { |
||||||
variable version |
variable version |
||||||
set version 0.1 |
set version 0.1 |
||||||
|
}] |
||||||
}] |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -1,239 +1,239 @@ |
|||||||
#utilities for punk apps to call |
#utilities for punk apps to call |
||||||
|
|
||||||
package provide punkapp [namespace eval punkapp { |
package provide punkapp [namespace eval punkapp { |
||||||
variable version |
variable version |
||||||
set version 0.1 |
set version 0.1 |
||||||
}] |
}] |
||||||
|
|
||||||
namespace eval punkapp { |
namespace eval punkapp { |
||||||
variable result |
variable result |
||||||
variable waiting "no" |
variable waiting "no" |
||||||
proc hide_dot_window {} { |
proc hide_dot_window {} { |
||||||
#alternative to wm withdraw . |
#alternative to wm withdraw . |
||||||
#see https://wiki.tcl-lang.org/page/wm+withdraw |
#see https://wiki.tcl-lang.org/page/wm+withdraw |
||||||
wm geometry . 1x1+0+0 |
wm geometry . 1x1+0+0 |
||||||
wm overrideredirect . 1 |
wm overrideredirect . 1 |
||||||
wm transient . |
wm transient . |
||||||
} |
} |
||||||
proc is_toplevel {w} { |
proc is_toplevel {w} { |
||||||
if {![llength [info commands winfo]]} { |
if {![llength [info commands winfo]]} { |
||||||
return 0 |
return 0 |
||||||
} |
} |
||||||
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} |
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} |
||||||
} |
} |
||||||
proc get_toplevels {{w .}} { |
proc get_toplevels {{w .}} { |
||||||
if {![llength [info commands winfo]]} { |
if {![llength [info commands winfo]]} { |
||||||
return [list] |
return [list] |
||||||
} |
} |
||||||
set list {} |
set list {} |
||||||
if {[is_toplevel $w]} { |
if {[is_toplevel $w]} { |
||||||
lappend list $w |
lappend list $w |
||||||
} |
} |
||||||
foreach w [winfo children $w] { |
foreach w [winfo children $w] { |
||||||
lappend list {*}[get_toplevels $w] |
lappend list {*}[get_toplevels $w] |
||||||
} |
} |
||||||
return $list |
return $list |
||||||
} |
} |
||||||
|
|
||||||
proc make_toplevel_next {prefix} { |
proc make_toplevel_next {prefix} { |
||||||
set top [get_toplevel_next $prefix] |
set top [get_toplevel_next $prefix] |
||||||
return [toplevel $top] |
return [toplevel $top] |
||||||
} |
} |
||||||
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime |
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime |
||||||
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? |
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? |
||||||
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix |
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix |
||||||
proc get_toplevel_next {prefix} { |
proc get_toplevel_next {prefix} { |
||||||
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" |
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
} |
} |
||||||
proc exit {{toplevel ""}} { |
proc exit {{toplevel ""}} { |
||||||
variable waiting |
variable waiting |
||||||
variable result |
variable result |
||||||
variable default_result |
variable default_result |
||||||
set toplevels [get_toplevels] |
set toplevels [get_toplevels] |
||||||
if {[string length $toplevel]} { |
if {[string length $toplevel]} { |
||||||
set wposn [lsearch $toplevels $toplevel] |
set wposn [lsearch $toplevels $toplevel] |
||||||
if {$wposn > 0} { |
if {$wposn > 0} { |
||||||
destroy $toplevel |
destroy $toplevel |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
#review |
#review |
||||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
puts stderr "punkapp::exit called without toplevel - showing console" |
puts stderr "punkapp::exit called without toplevel - showing console" |
||||||
show_console |
show_console |
||||||
return 0 |
return 0 |
||||||
} else { |
} else { |
||||||
puts stderr "punkapp::exit called without toplevel - exiting" |
puts stderr "punkapp::exit called without toplevel - exiting" |
||||||
if {$waiting ne "no"} { |
if {$waiting ne "no"} { |
||||||
if {[info exists result(shell)]} { |
if {[info exists result(shell)]} { |
||||||
set temp [set result(shell)] |
set temp [set result(shell)] |
||||||
unset result(shell) |
unset result(shell) |
||||||
set waiting $temp |
set waiting $temp |
||||||
} else { |
} else { |
||||||
set waiting "" |
set waiting "" |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
::exit |
::exit |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
set controllable [get_user_controllable_toplevels] |
set controllable [get_user_controllable_toplevels] |
||||||
if {![llength $controllable]} { |
if {![llength $controllable]} { |
||||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
show_console |
show_console |
||||||
} else { |
} else { |
||||||
if {$waiting ne "no"} { |
if {$waiting ne "no"} { |
||||||
if {[info exists result(shell)]} { |
if {[info exists result(shell)]} { |
||||||
set temp [set result(shell)] |
set temp [set result(shell)] |
||||||
unset result(shell) |
unset result(shell) |
||||||
set waiting $temp |
set waiting $temp |
||||||
} elseif {[info exists result($toplevel)]} { |
} elseif {[info exists result($toplevel)]} { |
||||||
set temp [set result($toplevel)] |
set temp [set result($toplevel)] |
||||||
unset result($toplevel) |
unset result($toplevel) |
||||||
set waiting $temp |
set waiting $temp |
||||||
} elseif {[info exists default_result]} { |
} elseif {[info exists default_result]} { |
||||||
set temp $default_result |
set temp $default_result |
||||||
unset default_result |
unset default_result |
||||||
set waiting $temp |
set waiting $temp |
||||||
} else { |
} else { |
||||||
set waiting "" |
set waiting "" |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
::exit |
::exit |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
proc close_window {toplevel} { |
proc close_window {toplevel} { |
||||||
wm withdraw $toplevel |
wm withdraw $toplevel |
||||||
if {![llength [get_user_controllable_toplevels]]} { |
if {![llength [get_user_controllable_toplevels]]} { |
||||||
punkapp::exit $toplevel |
punkapp::exit $toplevel |
||||||
} |
} |
||||||
destroy $toplevel |
destroy $toplevel |
||||||
} |
} |
||||||
proc wait {args} { |
proc wait {args} { |
||||||
variable waiting |
variable waiting |
||||||
variable default_result |
variable default_result |
||||||
if {[dict exists $args -defaultresult]} { |
if {[dict exists $args -defaultresult]} { |
||||||
set default_result [dict get $args -defaultresult] |
set default_result [dict get $args -defaultresult] |
||||||
} |
} |
||||||
foreach t [punkapp::get_toplevels] { |
foreach t [punkapp::get_toplevels] { |
||||||
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { |
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { |
||||||
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] |
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] |
||||||
} |
} |
||||||
} |
} |
||||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
puts stderr "repl eventloop seems to be running - punkapp::wait not required" |
puts stderr "repl eventloop seems to be running - punkapp::wait not required" |
||||||
} else { |
} else { |
||||||
if {$waiting eq "no"} { |
if {$waiting eq "no"} { |
||||||
set waiting "waiting" |
set waiting "waiting" |
||||||
vwait ::punkapp::waiting |
vwait ::punkapp::waiting |
||||||
return $::punkapp::waiting |
return $::punkapp::waiting |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
#A window can be 'visible' according to this - but underneath other windows etc |
#A window can be 'visible' according to this - but underneath other windows etc |
||||||
#REVIEW - change name? |
#REVIEW - change name? |
||||||
proc get_visible_toplevels {{w .}} { |
proc get_visible_toplevels {{w .}} { |
||||||
if {![llength [info commands winfo]]} { |
if {![llength [info commands winfo]]} { |
||||||
return [list] |
return [list] |
||||||
} |
} |
||||||
set list [get_toplevels $w] |
set list [get_toplevels $w] |
||||||
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] |
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] |
||||||
set mapped [concat {*}$mapped] ;#ignore {} |
set mapped [concat {*}$mapped] ;#ignore {} |
||||||
set visible [list] |
set visible [list] |
||||||
foreach m $mapped { |
foreach m $mapped { |
||||||
if {[wm overrideredirect $m] == 0 } { |
if {[wm overrideredirect $m] == 0 } { |
||||||
lappend visible $m |
lappend visible $m |
||||||
} else { |
} else { |
||||||
if {[winfo height $m] >1 && [winfo width $m] > 1} { |
if {[winfo height $m] >1 && [winfo width $m] > 1} { |
||||||
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 |
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 |
||||||
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible |
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible |
||||||
lappend visible $m |
lappend visible $m |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
return $visible |
return $visible |
||||||
} |
} |
||||||
proc get_user_controllable_toplevels {{w .}} { |
proc get_user_controllable_toplevels {{w .}} { |
||||||
set visible [get_visible_toplevels $w] |
set visible [get_visible_toplevels $w] |
||||||
set controllable [list] |
set controllable [list] |
||||||
foreach v $visible { |
foreach v $visible { |
||||||
if {[wm overrideredirect $v] == 0} { |
if {[wm overrideredirect $v] == 0} { |
||||||
lappend controllable $v |
lappend controllable $v |
||||||
} |
} |
||||||
} |
} |
||||||
#only return visible windows with overrideredirect == 0 because there exists some user control. |
#only return visible windows with overrideredirect == 0 because there exists some user control. |
||||||
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily |
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily |
||||||
return $controllable |
return $controllable |
||||||
} |
} |
||||||
proc hide_console {args} { |
proc hide_console {args} { |
||||||
set opts [dict create -force 0] |
set opts [dict create -force 0] |
||||||
if {([llength $args] % 2) != 0} { |
if {([llength $args] % 2) != 0} { |
||||||
error "hide_console expects pairs of arguments. e.g -force 1" |
error "hide_console expects pairs of arguments. e.g -force 1" |
||||||
} |
} |
||||||
#set known_opts [dict keys $defaults] |
#set known_opts [dict keys $defaults] |
||||||
foreach {k v} $args { |
foreach {k v} $args { |
||||||
switch -- $k { |
switch -- $k { |
||||||
-force { |
-force { |
||||||
dict set opts $k $v |
dict set opts $k $v |
||||||
} |
} |
||||||
default { |
default { |
||||||
error "Unrecognised options '$k' known options: [dict keys $opts]" |
error "Unrecognised options '$k' known options: [dict keys $opts]" |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
set force [dict get $opts -force] |
set force [dict get $opts -force] |
||||||
|
|
||||||
if {!$force} { |
if {!$force} { |
||||||
if {![llength [get_user_controllable_toplevels]]} { |
if {![llength [get_user_controllable_toplevels]]} { |
||||||
puts stderr "Cannot hide console while no user-controllable windows available" |
puts stderr "Cannot hide console while no user-controllable windows available" |
||||||
return 0 |
return 0 |
||||||
} |
} |
||||||
} |
} |
||||||
if {$::tcl_platform(platform) eq "windows"} { |
if {$::tcl_platform(platform) eq "windows"} { |
||||||
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. |
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. |
||||||
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. |
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. |
||||||
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. |
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. |
||||||
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) |
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) |
||||||
package require twapi |
package require twapi |
||||||
set h [twapi::get_console_window] |
set h [twapi::get_console_window] |
||||||
set pid [twapi::get_window_process $h] |
set pid [twapi::get_window_process $h] |
||||||
set pinfo [twapi::get_process_info $pid -name] |
set pinfo [twapi::get_process_info $pid -name] |
||||||
set pname [dict get $pinfo -name] |
set pname [dict get $pinfo -name] |
||||||
set wstyle [twapi::get_window_style $h] |
set wstyle [twapi::get_window_style $h] |
||||||
#tclkitsh/tclsh? |
#tclkitsh/tclsh? |
||||||
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { |
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { |
||||||
twapi::hide_window $h |
twapi::hide_window $h |
||||||
return 1 |
return 1 |
||||||
} else { |
} else { |
||||||
puts stderr "punkapp::hide_console unable to hide this type of console window" |
puts stderr "punkapp::hide_console unable to hide this type of console window" |
||||||
return 0 |
return 0 |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
#todo |
#todo |
||||||
puts stderr "punkapp::hide_console unimplemented on this platform (todo)" |
puts stderr "punkapp::hide_console unimplemented on this platform (todo)" |
||||||
return 0 |
return 0 |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
proc show_console {} { |
proc show_console {} { |
||||||
if {$::tcl_platform(platform) eq "windows"} { |
if {$::tcl_platform(platform) eq "windows"} { |
||||||
package require twapi |
package require twapi |
||||||
if {![catch {set h [twapi::get_console_window]} errM]} { |
if {![catch {set h [twapi::get_console_window]} errM]} { |
||||||
twapi::show_window $h -activate -normal |
twapi::show_window $h -activate -normal |
||||||
} else { |
} else { |
||||||
#no console - assume launched from something like wish? |
#no console - assume launched from something like wish? |
||||||
catch {console show} |
catch {console show} |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
#todo |
#todo |
||||||
puts stderr "punkapp::show_console unimplemented on this platform" |
puts stderr "punkapp::show_console unimplemented on this platform" |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
} |
} |
||||||
|
|||||||
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
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
File diff suppressed because it is too large
Load Diff
@ -1,487 +1,487 @@ |
|||||||
|
|
||||||
tcl::namespace::eval punk::config { |
tcl::namespace::eval punk::config { |
||||||
variable loaded |
variable loaded |
||||||
variable startup ;#include env overrides |
variable startup ;#include env overrides |
||||||
variable running |
variable running |
||||||
variable punk_env_vars |
variable punk_env_vars |
||||||
variable other_env_vars |
variable other_env_vars |
||||||
|
|
||||||
variable vars |
variable vars |
||||||
|
|
||||||
namespace export {[a-z]*} |
namespace export {[a-z]*} |
||||||
|
|
||||||
#todo - XDG_DATA_HOME etc |
#todo - XDG_DATA_HOME etc |
||||||
#https://specifications.freedesktop.org/basedir-spec/latest/ |
#https://specifications.freedesktop.org/basedir-spec/latest/ |
||||||
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ |
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ |
||||||
|
|
||||||
proc init {} { |
proc init {} { |
||||||
variable defaults |
variable defaults |
||||||
variable startup |
variable startup |
||||||
variable running |
variable running |
||||||
variable punk_env_vars |
variable punk_env_vars |
||||||
variable punk_env_vars_config |
variable punk_env_vars_config |
||||||
variable other_env_vars |
variable other_env_vars |
||||||
variable other_env_vars_config |
variable other_env_vars_config |
||||||
|
|
||||||
set exename "" |
set exename "" |
||||||
catch { |
catch { |
||||||
#catch for safe interps |
#catch for safe interps |
||||||
#safe base will return empty string, ordinary safe interp will raise error |
#safe base will return empty string, ordinary safe interp will raise error |
||||||
set exename [tcl::info::nameofexecutable] |
set exename [tcl::info::nameofexecutable] |
||||||
} |
} |
||||||
if {$exename ne ""} { |
if {$exename ne ""} { |
||||||
set exefolder [file dirname $exename] |
set exefolder [file dirname $exename] |
||||||
#default file logs to logs folder at same level as exe if writable, or empty string |
#default file logs to logs folder at same level as exe if writable, or empty string |
||||||
set log_folder [file normalize $exefolder/../logs] ;#~2ms |
set log_folder [file normalize $exefolder/../logs] ;#~2ms |
||||||
#tcl::dict::set startup scriptlib $exefolder/scriptlib |
#tcl::dict::set startup scriptlib $exefolder/scriptlib |
||||||
#tcl::dict::set startup apps $exefolder/../../punkapps |
#tcl::dict::set startup apps $exefolder/../../punkapps |
||||||
|
|
||||||
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc |
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc |
||||||
set default_scriptlib $exefolder/scriptlib |
set default_scriptlib $exefolder/scriptlib |
||||||
set default_apps $exefolder/../../punkapps |
set default_apps $exefolder/../../punkapps |
||||||
if {[file isdirectory $log_folder] && [file writable $log_folder]} { |
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_stdout $log_folder/repl-exec-stdout.txt |
||||||
#tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.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_stdout $log_folder/repl-exec-stdout.txt |
||||||
set default_logfile_stderr $log_folder/repl-exec-stderr.txt |
set default_logfile_stderr $log_folder/repl-exec-stderr.txt |
||||||
} else { |
} else { |
||||||
set default_logfile_stdout "" |
set default_logfile_stdout "" |
||||||
set default_logfile_stderr "" |
set default_logfile_stderr "" |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island |
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island |
||||||
#review - todo? |
#review - todo? |
||||||
#tcl::dict::set startup scriptlib "" |
#tcl::dict::set startup scriptlib "" |
||||||
#tcl::dict::set startup apps "" |
#tcl::dict::set startup apps "" |
||||||
set default_scriptlib "" |
set default_scriptlib "" |
||||||
set default_apps "" |
set default_apps "" |
||||||
set default_logfile_stdout "" |
set default_logfile_stdout "" |
||||||
set default_logfile_stderr "" |
set default_logfile_stderr "" |
||||||
} |
} |
||||||
|
|
||||||
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run |
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run |
||||||
|
|
||||||
#optional channel transforms on stdout/stderr. |
#optional channel transforms on stdout/stderr. |
||||||
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands |
#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> |
#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. |
#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 |
#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 brightwhite ;#stdout colour including background calls (after etc) |
||||||
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only |
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. |
#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 "red bold" |
||||||
#set default_color_stderr "web-lightsalmon" |
#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 yellow ;#limit to basic colours for wider terminal support. yellow = term-olive |
||||||
set default_color_stderr_repl "" ;#during repl call only |
set default_color_stderr_repl "" ;#during repl call only |
||||||
|
|
||||||
set homedir "" |
set homedir "" |
||||||
if {[catch { |
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 |
#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 |
#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] |
set homedir [file home] |
||||||
} errM]} { |
} errM]} { |
||||||
#tcl 8.6 doesn't have file home.. try again |
#tcl 8.6 doesn't have file home.. try again |
||||||
if {[info exists ::env(HOME)]} { |
if {[info exists ::env(HOME)]} { |
||||||
set homedir $::env(HOME) |
set homedir $::env(HOME) |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
|
|
||||||
# per user xdg vars |
# per user xdg vars |
||||||
# --- |
# --- |
||||||
set default_xdg_config_home "" ;#config data - portable |
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_data_home "" ;#data the user likely to want to be portable |
||||||
set default_xdg_cache_home "" ;#local cache |
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_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 |
set default_xdg_data_dirs "" ;#non-user specific |
||||||
#xdg_config_dirs ? |
#xdg_config_dirs ? |
||||||
#xdg_runtime_dir ? |
#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) |
#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) |
#(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. |
#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 {$homedir ne ""} { |
||||||
if {"windows" eq $::tcl_platform(platform)} { |
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. |
#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) |
#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. |
#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)]} { |
if {[info exists ::env(APPDATA)]} { |
||||||
set default_xdg_config_home $::env(APPDATA) |
set default_xdg_config_home $::env(APPDATA) |
||||||
set default_xdg_data_home $::env(APPDATA) |
set default_xdg_data_home $::env(APPDATA) |
||||||
} |
} |
||||||
|
|
||||||
#The xdg_cache_home should be kept local |
#The xdg_cache_home should be kept local |
||||||
if {[info exists ::env(LOCALAPPDATA)]} { |
if {[info exists ::env(LOCALAPPDATA)]} { |
||||||
set default_xdg_cache_home $::env(LOCALAPPDATA) |
set default_xdg_cache_home $::env(LOCALAPPDATA) |
||||||
set default_xdg_state_home $::env(LOCALAPPDATA) |
set default_xdg_state_home $::env(LOCALAPPDATA) |
||||||
} |
} |
||||||
|
|
||||||
if {[info exists ::env(PROGRAMDATA)]} { |
if {[info exists ::env(PROGRAMDATA)]} { |
||||||
#- equiv env(ALLUSERSPROFILE) ? |
#- equiv env(ALLUSERSPROFILE) ? |
||||||
set default_xdg_data_dirs $::env(PROGRAMDATA) |
set default_xdg_data_dirs $::env(PROGRAMDATA) |
||||||
} |
} |
||||||
|
|
||||||
} else { |
} else { |
||||||
#follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html |
#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_config_home [file join $homedir .config] |
||||||
set default_xdg_data_home [file join $homedir .local share] |
set default_xdg_data_home [file join $homedir .local share] |
||||||
set default_xdg_cache_home [file join $homedir .cache] |
set default_xdg_cache_home [file join $homedir .cache] |
||||||
set default_xdg_state_home [file join $homedir .local state] |
set default_xdg_state_home [file join $homedir .local state] |
||||||
set default_xdg_data_dirs /usr/local/share |
set default_xdg_data_dirs /usr/local/share |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
set defaults [dict create\ |
set defaults [dict create\ |
||||||
apps $default_apps\ |
apps $default_apps\ |
||||||
config ""\ |
config ""\ |
||||||
configset ".punkshell"\ |
configset ".punkshell"\ |
||||||
scriptlib $default_scriptlib\ |
scriptlib $default_scriptlib\ |
||||||
color_stdout $default_color_stdout\ |
color_stdout $default_color_stdout\ |
||||||
color_stdout_repl $default_color_stdout_repl\ |
color_stdout_repl $default_color_stdout_repl\ |
||||||
color_stderr $default_color_stderr\ |
color_stderr $default_color_stderr\ |
||||||
color_stderr_repl $default_color_stderr_repl\ |
color_stderr_repl $default_color_stderr_repl\ |
||||||
logfile_stdout $default_logfile_stdout\ |
logfile_stdout $default_logfile_stdout\ |
||||||
logfile_stderr $default_logfile_stderr\ |
logfile_stderr $default_logfile_stderr\ |
||||||
logfile_active 0\ |
logfile_active 0\ |
||||||
syslog_stdout "127.0.0.1:514"\ |
syslog_stdout "127.0.0.1:514"\ |
||||||
syslog_stderr "127.0.0.1:514"\ |
syslog_stderr "127.0.0.1:514"\ |
||||||
syslog_active 0\ |
syslog_active 0\ |
||||||
auto_exec_mechanism exec\ |
auto_exec_mechanism exec\ |
||||||
auto_noexec 0\ |
auto_noexec 0\ |
||||||
xdg_config_home $default_xdg_config_home\ |
xdg_config_home $default_xdg_config_home\ |
||||||
xdg_data_home $default_xdg_data_home\ |
xdg_data_home $default_xdg_data_home\ |
||||||
xdg_cache_home $default_xdg_cache_home\ |
xdg_cache_home $default_xdg_cache_home\ |
||||||
xdg_state_home $default_xdg_state_home\ |
xdg_state_home $default_xdg_state_home\ |
||||||
xdg_data_dirs $default_xdg_data_dirs\ |
xdg_data_dirs $default_xdg_data_dirs\ |
||||||
theme_posh_override ""\ |
theme_posh_override ""\ |
||||||
posh_theme ""\ |
posh_theme ""\ |
||||||
posh_themes_path ""\ |
posh_themes_path ""\ |
||||||
] |
] |
||||||
|
|
||||||
set startup $defaults |
set startup $defaults |
||||||
#load values from saved config file - $xdg_config_home/punk/punk.config ? |
#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. |
#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 |
#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? |
#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? |
#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 |
#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? |
#- 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. |
#we are likely to want the saved configs for subshells/decks to override them however. |
||||||
|
|
||||||
#todo - load/save config file |
#todo - load/save config file |
||||||
|
|
||||||
#todo - define which configvars are settable in env |
#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) |
#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 \ |
set punk_env_vars_config [dict create \ |
||||||
PUNK_APPS {type pathlist}\ |
PUNK_APPS {type pathlist}\ |
||||||
PUNK_CONFIG {type string}\ |
PUNK_CONFIG {type string}\ |
||||||
PUNK_CONFIGSET {type string}\ |
PUNK_CONFIGSET {type string}\ |
||||||
PUNK_SCRIPTLIB {type string}\ |
PUNK_SCRIPTLIB {type string}\ |
||||||
PUNK_AUTO_EXEC_MECHANISM {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_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 {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_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 {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_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ |
||||||
PUNK_LOGFILE_STDOUT {type string}\ |
PUNK_LOGFILE_STDOUT {type string}\ |
||||||
PUNK_LOGFILE_STDERR {type string}\ |
PUNK_LOGFILE_STDERR {type string}\ |
||||||
PUNK_LOGFILE_ACTIVE {type string}\ |
PUNK_LOGFILE_ACTIVE {type string}\ |
||||||
PUNK_SYSLOG_STDOUT {type string}\ |
PUNK_SYSLOG_STDOUT {type string}\ |
||||||
PUNK_SYSLOG_STDERR {type string}\ |
PUNK_SYSLOG_STDERR {type string}\ |
||||||
PUNK_SYSLOG_ACTIVE {type string}\ |
PUNK_SYSLOG_ACTIVE {type string}\ |
||||||
PUNK_THEME_POSH_OVERRIDE {type string}\ |
PUNK_THEME_POSH_OVERRIDE {type string}\ |
||||||
] |
] |
||||||
set punk_env_vars [dict keys $punk_env_vars_config] |
set punk_env_vars [dict keys $punk_env_vars_config] |
||||||
|
|
||||||
#override with env vars if set |
#override with env vars if set |
||||||
foreach {evar varinfo} $punk_env_vars_config { |
foreach {evar varinfo} $punk_env_vars_config { |
||||||
if {[info exists ::env($evar)]} { |
if {[info exists ::env($evar)]} { |
||||||
set vartype [dict get $varinfo type] |
set vartype [dict get $varinfo type] |
||||||
set f [set ::env($evar)] |
set f [set ::env($evar)] |
||||||
if {$f ne "default"} { |
if {$f ne "default"} { |
||||||
#e.g PUNK_SCRIPTLIB -> scriptlib |
#e.g PUNK_SCRIPTLIB -> scriptlib |
||||||
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] |
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] |
||||||
if {$vartype eq "pathlist"} { |
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 |
#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. |
#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. |
#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. |
#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 |
#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. |
# - 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 paths [split $f $::tcl_platform(pathSeparator)] |
||||||
set final [list] |
set final [list] |
||||||
#eliminate empty values (leading or trailing or extraneous separators) |
#eliminate empty values (leading or trailing or extraneous separators) |
||||||
foreach p $paths { |
foreach p $paths { |
||||||
if {[tcl::string::trim $p] ne ""} { |
if {[tcl::string::trim $p] ne ""} { |
||||||
lappend final $p |
lappend final $p |
||||||
} |
} |
||||||
} |
} |
||||||
tcl::dict::set startup $varname $final |
tcl::dict::set startup $varname $final |
||||||
} else { |
} else { |
||||||
tcl::dict::set startup $varname $f |
tcl::dict::set startup $varname $f |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
# https://no-color.org |
# https://no-color.org |
||||||
#if {[info exists ::env(NO_COLOR)]} { |
#if {[info exists ::env(NO_COLOR)]} { |
||||||
# if {$::env(NO_COLOR) ne ""} { |
# if {$::env(NO_COLOR) ne ""} { |
||||||
# set colour_disabled 1 |
# set colour_disabled 1 |
||||||
# } |
# } |
||||||
#} |
#} |
||||||
set other_env_vars_config [dict create\ |
set other_env_vars_config [dict create\ |
||||||
NO_COLOR {type string}\ |
NO_COLOR {type string}\ |
||||||
XDG_CONFIG_HOME {type string}\ |
XDG_CONFIG_HOME {type string}\ |
||||||
XDG_DATA_HOME {type string}\ |
XDG_DATA_HOME {type string}\ |
||||||
XDG_CACHE_HOME {type string}\ |
XDG_CACHE_HOME {type string}\ |
||||||
XDG_STATE_HOME {type string}\ |
XDG_STATE_HOME {type string}\ |
||||||
XDG_DATA_DIRS {type pathlist}\ |
XDG_DATA_DIRS {type pathlist}\ |
||||||
POSH_THEME {type string}\ |
POSH_THEME {type string}\ |
||||||
POSH_THEMES_PATH {type string}\ |
POSH_THEMES_PATH {type string}\ |
||||||
TCLLIBPATH {type string}\ |
TCLLIBPATH {type string}\ |
||||||
] |
] |
||||||
lassign [split [info tclversion] .] tclmajorv tclminorv |
lassign [split [info tclversion] .] tclmajorv tclminorv |
||||||
#don't rely on lseq or punk::lib for now.. |
#don't rely on lseq or punk::lib for now.. |
||||||
set relevant_minors [list] |
set relevant_minors [list] |
||||||
for {set i 0} {$i <= $tclminorv} {incr i} { |
for {set i 0} {$i <= $tclminorv} {incr i} { |
||||||
lappend relevant_minors $i |
lappend relevant_minors $i |
||||||
} |
} |
||||||
foreach minor $relevant_minors { |
foreach minor $relevant_minors { |
||||||
set vname TCL${tclmajorv}_${minor}_TM_PATH |
set vname TCL${tclmajorv}_${minor}_TM_PATH |
||||||
if {$minor eq $tclminorv || [info exists ::env($vname)]} { |
if {$minor eq $tclminorv || [info exists ::env($vname)]} { |
||||||
dict set other_env_vars_config $vname {type string} |
dict set other_env_vars_config $vname {type string} |
||||||
} |
} |
||||||
} |
} |
||||||
set other_env_vars [dict keys $other_env_vars_config] |
set other_env_vars [dict keys $other_env_vars_config] |
||||||
|
|
||||||
foreach {evar varinfo} $other_env_vars_config { |
foreach {evar varinfo} $other_env_vars_config { |
||||||
if {[info exists ::env($evar)]} { |
if {[info exists ::env($evar)]} { |
||||||
set vartype [dict get $varinfo type] |
set vartype [dict get $varinfo type] |
||||||
set f [set ::env($evar)] |
set f [set ::env($evar)] |
||||||
if {$f ne "default"} { |
if {$f ne "default"} { |
||||||
set varname [tcl::string::tolower $evar] |
set varname [tcl::string::tolower $evar] |
||||||
if {$vartype eq "pathlist"} { |
if {$vartype eq "pathlist"} { |
||||||
set paths [split $f $::tcl_platform(pathSeparator)] |
set paths [split $f $::tcl_platform(pathSeparator)] |
||||||
set final [list] |
set final [list] |
||||||
#eliminate empty values (leading or trailing or extraneous separators) |
#eliminate empty values (leading or trailing or extraneous separators) |
||||||
foreach p $paths { |
foreach p $paths { |
||||||
if {[tcl::string::trim $p] ne ""} { |
if {[tcl::string::trim $p] ne ""} { |
||||||
lappend final $p |
lappend final $p |
||||||
} |
} |
||||||
} |
} |
||||||
tcl::dict::set startup $varname $final |
tcl::dict::set startup $varname $final |
||||||
} else { |
} else { |
||||||
tcl::dict::set startup $varname $f |
tcl::dict::set startup $varname $f |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
|
|
||||||
#unset -nocomplain vars |
#unset -nocomplain vars |
||||||
|
|
||||||
#todo |
#todo |
||||||
set running [tcl::dict::create] |
set running [tcl::dict::create] |
||||||
set running [tcl::dict::merge $running $startup] |
set running [tcl::dict::merge $running $startup] |
||||||
} |
} |
||||||
init |
init |
||||||
|
|
||||||
#todo |
#todo |
||||||
proc Apply {config} { |
proc Apply {config} { |
||||||
puts stderr "punk::config::Apply partially implemented" |
puts stderr "punk::config::Apply partially implemented" |
||||||
set configname [string map {-config ""} $config] |
set configname [string map {-config ""} $config] |
||||||
if {$configname in {startup running}} { |
if {$configname in {startup running}} { |
||||||
upvar ::punk::config::$configname applyconfig |
upvar ::punk::config::$configname applyconfig |
||||||
|
|
||||||
if {[dict exists $applyconfig auto_noexec]} { |
if {[dict exists $applyconfig auto_noexec]} { |
||||||
set auto [dict get $applyconfig auto_noexec] |
set auto [dict get $applyconfig auto_noexec] |
||||||
if {![string is boolean -strict $auto]} { |
if {![string is boolean -strict $auto]} { |
||||||
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" |
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" |
||||||
} |
} |
||||||
if {$auto} { |
if {$auto} { |
||||||
set ::auto_noexec 1 |
set ::auto_noexec 1 |
||||||
} else { |
} else { |
||||||
#puts "auto_noexec false" |
#puts "auto_noexec false" |
||||||
unset -nocomplain ::auto_noexec |
unset -nocomplain ::auto_noexec |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
} else { |
} else { |
||||||
error "no config named '$config' found" |
error "no config named '$config' found" |
||||||
} |
} |
||||||
return "apply done" |
return "apply done" |
||||||
} |
} |
||||||
Apply startup |
Apply startup |
||||||
|
|
||||||
#todo - consider how to divide up settings, categories, 'devices', decks etc |
#todo - consider how to divide up settings, categories, 'devices', decks etc |
||||||
proc get_running_global {varname} { |
proc get_running_global {varname} { |
||||||
variable running |
variable running |
||||||
if {[dict exists $running $varname]} { |
if {[dict exists $running $varname]} { |
||||||
return [dict get $running $varname] |
return [dict get $running $varname] |
||||||
} |
} |
||||||
error "No such global configuration item '$varname' found in running config" |
error "No such global configuration item '$varname' found in running config" |
||||||
} |
} |
||||||
proc get_startup_global {varname} { |
proc get_startup_global {varname} { |
||||||
variable startup |
variable startup |
||||||
if {[dict exists $startup $varname]} { |
if {[dict exists $startup $varname]} { |
||||||
return [dict get $startup $varname] |
return [dict get $startup $varname] |
||||||
} |
} |
||||||
error "No such global configuration item '$varname' found in startup config" |
error "No such global configuration item '$varname' found in startup config" |
||||||
} |
} |
||||||
|
|
||||||
proc get {whichconfig {globfor *}} { |
proc get {whichconfig {globfor *}} { |
||||||
variable startup |
variable startup |
||||||
variable running |
variable running |
||||||
switch -- $whichconfig { |
switch -- $whichconfig { |
||||||
config - startup - startup-config - startup-configuration { |
config - startup - startup-config - startup-configuration { |
||||||
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs |
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs |
||||||
set configdata $startup |
set configdata $startup |
||||||
} |
} |
||||||
running - running-config - running-configuration { |
running - running-config - running-configuration { |
||||||
set configdata $running |
set configdata $running |
||||||
} |
} |
||||||
default { |
default { |
||||||
error "Unknown config name '$whichconfig' - try startup or running" |
error "Unknown config name '$whichconfig' - try startup or running" |
||||||
} |
} |
||||||
} |
} |
||||||
if {$globfor eq "*"} { |
if {$globfor eq "*"} { |
||||||
return $configdata |
return $configdata |
||||||
} else { |
} else { |
||||||
set keys [dict keys $configdata [string tolower $globfor]] |
set keys [dict keys $configdata [string tolower $globfor]] |
||||||
set filtered [dict create] |
set filtered [dict create] |
||||||
foreach k $keys { |
foreach k $keys { |
||||||
dict set filtered $k [dict get $configdata $k] |
dict set filtered $k [dict get $configdata $k] |
||||||
} |
} |
||||||
return $filtered |
return $filtered |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
proc configure {args} { |
proc configure {args} { |
||||||
set argdef { |
set argdef { |
||||||
@id -id ::punk::config::configure |
@id -id ::punk::config::configure |
||||||
@cmd -name punk::config::configure -help\ |
@cmd -name punk::config::configure -help\ |
||||||
"UNIMPLEMENTED" |
"UNIMPLEMENTED" |
||||||
@values -min 1 -max 1 |
@values -min 1 -max 1 |
||||||
whichconfig -type string -choices {startup running stop} |
whichconfig -type string -choices {startup running stop} |
||||||
} |
} |
||||||
set argd [punk::args::get_dict $argdef $args] |
set argd [punk::args::get_dict $argdef $args] |
||||||
return "unimplemented - $argd" |
return "unimplemented - $argd" |
||||||
} |
} |
||||||
|
|
||||||
proc show {whichconfig {globfor *}} { |
proc show {whichconfig {globfor *}} { |
||||||
#todo - tables for console |
#todo - tables for console |
||||||
set configdata [punk::config::get $whichconfig $globfor] |
set configdata [punk::config::get $whichconfig $globfor] |
||||||
return [punk::lib::showdict $configdata] |
return [punk::lib::showdict $configdata] |
||||||
} |
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#e.g |
#e.g |
||||||
# copy running-config startup-config |
# copy running-config startup-config |
||||||
# copy startup-config test-config.cfg |
# copy startup-config test-config.cfg |
||||||
# copy backup-config.cfg running-config |
# 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 |
#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 |
#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} { |
proc copy {args} { |
||||||
set argdef { |
set argdef { |
||||||
@id -id ::punk::config::copy |
@id -id ::punk::config::copy |
||||||
@cmd -name punk::config::copy -help\ |
@cmd -name punk::config::copy -help\ |
||||||
"Copy a partial or full configuration from one config to another |
"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. |
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\ |
-type -default "" -choices {replace merge} -help\ |
||||||
"Defaults to merge when target is running-config |
"Defaults to merge when target is running-config |
||||||
Defaults to replace when source is running-config" |
Defaults to replace when source is running-config" |
||||||
@values -min 2 -max 2 |
@values -min 2 -max 2 |
||||||
fromconfig -help\ |
fromconfig -help\ |
||||||
"running or startup or file name (not fully implemented)" |
"running or startup or file name (not fully implemented)" |
||||||
toconfig -help\ |
toconfig -help\ |
||||||
"running or startup or file name (not fully implemented)" |
"running or startup or file name (not fully implemented)" |
||||||
} |
} |
||||||
set argd [punk::args::get_dict $argdef $args] |
set argd [punk::args::get_dict $argdef $args] |
||||||
set fromconfig [dict get $argd values fromconfig] |
set fromconfig [dict get $argd values fromconfig] |
||||||
set toconfig [dict get $argd values toconfig] |
set toconfig [dict get $argd values toconfig] |
||||||
set fromconfig [string map {-config ""} $fromconfig] |
set fromconfig [string map {-config ""} $fromconfig] |
||||||
set toconfig [string map {-config ""} $toconfig] |
set toconfig [string map {-config ""} $toconfig] |
||||||
|
|
||||||
set copytype [dict get $argd opts -type] |
set copytype [dict get $argd opts -type] |
||||||
|
|
||||||
|
|
||||||
#todo - warn & prompt if doing merge copy to startup |
#todo - warn & prompt if doing merge copy to startup |
||||||
switch -exact -- $fromconfig-$toconfig { |
switch -exact -- $fromconfig-$toconfig { |
||||||
running-startup { |
running-startup { |
||||||
if {$copytype eq ""} { |
if {$copytype eq ""} { |
||||||
set copytype replace ;#full configuration |
set copytype replace ;#full configuration |
||||||
} |
} |
||||||
if {$copytype eq "replace"} { |
if {$copytype eq "replace"} { |
||||||
error "punk::config::copy error. full configuration copy from running to startup config not yet supported" |
error "punk::config::copy error. full configuration copy from running to startup config not yet supported" |
||||||
} else { |
} else { |
||||||
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" |
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" |
||||||
} |
} |
||||||
} |
} |
||||||
startup-running { |
startup-running { |
||||||
#default type merge - even though it's not always what is desired |
#default type merge - even though it's not always what is desired |
||||||
if {$copytype eq ""} { |
if {$copytype eq ""} { |
||||||
set copytype merge ;#load in a partial configuration |
set copytype merge ;#load in a partial configuration |
||||||
} |
} |
||||||
|
|
||||||
#warn/prompt either way |
#warn/prompt either way |
||||||
if {$copytype eq "replace"} { |
if {$copytype eq "replace"} { |
||||||
#some routers require use of a separate command for this branch. |
#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 |
#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" |
error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" |
||||||
} else { |
} else { |
||||||
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" |
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" |
||||||
} |
} |
||||||
} |
} |
||||||
default { |
default { |
||||||
error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" |
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? |
#todo - move to cli? |
||||||
::tcl::namespace::eval punk::config { |
::tcl::namespace::eval punk::config { |
||||||
#todo - something better - 'previous' rather than reverting to startup |
#todo - something better - 'previous' rather than reverting to startup |
||||||
proc channelcolors {{onoff {}}} { |
proc channelcolors {{onoff {}}} { |
||||||
variable running |
variable running |
||||||
variable startup |
variable startup |
||||||
|
|
||||||
if {![string length $onoff]} { |
if {![string length $onoff]} { |
||||||
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
||||||
} else { |
} else { |
||||||
if {![string is boolean $onoff]} { |
if {![string is boolean $onoff]} { |
||||||
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" |
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" |
||||||
} |
} |
||||||
if {$onoff} { |
if {$onoff} { |
||||||
dict set running color_stdout [dict get $startup color_stdout] |
dict set running color_stdout [dict get $startup color_stdout] |
||||||
dict set running color_stderr [dict get $startup color_stderr] |
dict set running color_stderr [dict get $startup color_stderr] |
||||||
} else { |
} else { |
||||||
dict set running color_stdout "" |
dict set running color_stdout "" |
||||||
dict set running color_stderr "" |
dict set running color_stderr "" |
||||||
} |
} |
||||||
} |
} |
||||||
return [list stdout [dict get $running color_stdout] stderr [dict get $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 { |
package provide punk::config [tcl::namespace::eval punk::config { |
||||||
variable version |
variable version |
||||||
set version 0.1 |
set version 0.1 |
||||||
|
|
||||||
}] |
}] |
||||||
@ -1,164 +1,163 @@ |
|||||||
#punkapps app manager |
#punkapps app manager |
||||||
# deck cli |
# deck cli |
||||||
|
|
||||||
namespace eval punk::mod::cli { |
namespace eval punk::mod::cli { |
||||||
namespace export help list run |
namespace export help list run |
||||||
namespace ensemble create |
namespace ensemble create |
||||||
|
|
||||||
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown |
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown |
||||||
if 0 { |
if 0 { |
||||||
proc _unknown {ns args} { |
proc _unknown {ns args} { |
||||||
puts stderr "punk::mod::cli::_unknown '$ns' '$args'" |
puts stderr "punk::mod::cli::_unknown '$ns' '$args'" |
||||||
puts stderr "punk::mod::cli::help $args" |
puts stderr "punk::mod::cli::help $args" |
||||||
puts stderr "arglen:[llength $args]" |
puts stderr "arglen:[llength $args]" |
||||||
punk::mod::cli::help {*}$args |
punk::mod::cli::help {*}$args |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
#cli must have _init method - usually used to load commandsets lazily |
#cli must have _init method - usually used to load commandsets lazily |
||||||
# |
# |
||||||
variable initialised 0 |
variable initialised 0 |
||||||
proc _init {args} { |
proc _init {args} { |
||||||
variable initialised |
variable initialised |
||||||
if {$initialised} { |
if {$initialised} { |
||||||
return |
return |
||||||
} |
} |
||||||
#... |
#... |
||||||
set initialised 1 |
set initialised 1 |
||||||
} |
} |
||||||
|
|
||||||
proc help {args} { |
proc help {args} { |
||||||
set basehelp [punk::mix::base help {*}$args] |
set basehelp [punk::mix::base help {*}$args] |
||||||
#namespace export |
#namespace export |
||||||
return $basehelp |
return $basehelp |
||||||
} |
} |
||||||
proc getraw {appname} { |
proc getraw {appname} { |
||||||
upvar ::punk::config::running running_config |
upvar ::punk::config::running running_config |
||||||
set app_folders [dict get $running_config apps] |
set app_folders [dict get $running_config apps] |
||||||
#todo search each app folder |
#todo search each app folder |
||||||
set bases [::list] |
set bases [::list] |
||||||
set versions [::list] |
set versions [::list] |
||||||
set mains [::list] |
set mains [::list] |
||||||
set appinfo [::list bases {} mains {} versions {}] |
set appinfo [::list bases {} mains {} versions {}] |
||||||
|
|
||||||
foreach containerfolder $app_folders { |
foreach containerfolder $app_folders { |
||||||
lappend bases $containerfolder |
lappend bases $containerfolder |
||||||
if {[file exists $containerfolder]} { |
if {[file exists $containerfolder]} { |
||||||
if {[file exists $containerfolder/$appname/main.tcl]} { |
if {[file exists $containerfolder/$appname/main.tcl]} { |
||||||
#exact match - only return info for the exact one specified |
#exact match - only return info for the exact one specified |
||||||
set namematches $appname |
set namematches $appname |
||||||
set parts [split $appname -] |
set parts [split $appname -] |
||||||
} else { |
} else { |
||||||
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] |
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] |
||||||
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||||
} |
} |
||||||
foreach nm $namematches { |
foreach nm $namematches { |
||||||
set mainfile $containerfolder/$nm/main.tcl |
set mainfile $containerfolder/$nm/main.tcl |
||||||
set parts [split $nm -] |
set parts [split $nm -] |
||||||
if {[llength $parts] == 1} { |
if {[llength $parts] == 1} { |
||||||
set ver "" |
set ver "" |
||||||
} else { |
} else { |
||||||
set ver [lindex $parts end] |
set ver [lindex $parts end] |
||||||
} |
} |
||||||
if {$ver ni $versions} { |
if {$ver ni $versions} { |
||||||
lappend versions $ver |
lappend versions $ver |
||||||
lappend mains $ver $mainfile |
lappend mains $ver $mainfile |
||||||
} else { |
} 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)" |
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 { |
} else { |
||||||
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" |
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" |
||||||
} |
} |
||||||
} |
} |
||||||
dict set appinfo versions $versions |
dict set appinfo versions $versions |
||||||
#todo - natsort! |
#todo - natsort! |
||||||
set sorted_versions [lsort $versions] |
set sorted_versions [lsort $versions] |
||||||
set latest [lindex $sorted_versions 0] |
set latest [lindex $sorted_versions 0] |
||||||
if {$latest eq "" && [llength $sorted_versions] > 1} { |
if {$latest eq "" && [llength $sorted_versions] > 1} { |
||||||
set latest [lindex $sorted_versions 1 |
set latest [lindex $sorted_versions 1] |
||||||
} |
} |
||||||
dict set appinfo latest $latest |
dict set appinfo latest $latest |
||||||
|
|
||||||
dict set appinfo bases $bases |
dict set appinfo bases $bases |
||||||
dict set appinfo mains $mains |
dict set appinfo mains $mains |
||||||
return $appinfo |
return $appinfo |
||||||
} |
} |
||||||
|
|
||||||
proc list {{glob *}} { |
proc list {{glob *}} { |
||||||
upvar ::punk::config::running running_config |
upvar ::punk::config::running running_config |
||||||
set apps_folder [dict get $running_config apps] |
set apps_folder [dict get $running_config apps] |
||||||
if {[file exists $apps_folder]} { |
if {[file exists $apps_folder]} { |
||||||
if {[file exists $apps_folder/$glob]} { |
if {[file exists $apps_folder/$glob]} { |
||||||
#tailcall source $apps_folder/$glob/main.tcl |
#tailcall source $apps_folder/$glob/main.tcl |
||||||
return $glob |
return $glob |
||||||
} |
} |
||||||
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] |
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] |
||||||
if {[llength $apps] == 0} { |
if {[llength $apps] == 0} { |
||||||
if {[string first * $glob] <0 && [string first ? $glob] <0} { |
if {[string first * $glob] <0 && [string first ? $glob] <0} { |
||||||
#no glob chars supplied - only launch if exact match for name part |
#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 [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] |
||||||
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||||
if {[llength $namematches] > 0} { |
if {[llength $namematches] > 0} { |
||||||
set latest [lindex $namematches end] |
set latest [lindex $namematches end] |
||||||
lassign $latest nm ver |
lassign $latest nm ver |
||||||
#tailcall source $apps_folder/$latest/main.tcl |
#tailcall source $apps_folder/$latest/main.tcl |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
return $apps |
return $apps |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
#todo - way to launch as separate process |
#todo - way to launch as separate process |
||||||
# solo-opts only before appname - args following appname are passed to the app |
# solo-opts only before appname - args following appname are passed to the app |
||||||
proc run {args} { |
proc run {args} { |
||||||
set nameposn [lsearch -not $args -*] |
set nameposn [lsearch -not $args -*] |
||||||
if {$nameposn < 0} { |
if {$nameposn < 0} { |
||||||
error "punkapp::run unable to determine application name" |
error "punkapp::run unable to determine application name" |
||||||
} |
} |
||||||
set appname [lindex $args $nameposn] |
set appname [lindex $args $nameposn] |
||||||
set controlargs [lrange $args 0 $nameposn-1] |
set controlargs [lrange $args 0 $nameposn-1] |
||||||
set appargs [lrange $args $nameposn+1 end] |
set appargs [lrange $args $nameposn+1 end] |
||||||
|
|
||||||
set appinfo [punk::mod::cli::getraw $appname] |
set appinfo [punk::mod::cli::getraw $appname] |
||||||
if {[llength [dict get $appinfo versions]]} { |
if {[llength [dict get $appinfo versions]]} { |
||||||
set ver [dict get $appinfo latest] |
set ver [dict get $appinfo latest] |
||||||
puts stdout "info: $appinfo" |
puts stdout "info: $appinfo" |
||||||
set ::argc [llength $appargs] |
set ::argc [llength $appargs] |
||||||
set ::argv $appargs |
set ::argv $appargs |
||||||
source [dict get $appinfo mains $ver] |
source [dict get $appinfo mains $ver] |
||||||
if {"-hideconsole" in $controlargs} { |
if {"-hideconsole" in $controlargs} { |
||||||
puts stderr "attempting console hide" |
puts stderr "attempting console hide" |
||||||
#todo - something better - a callback when window mapped? |
#todo - something better - a callback when window mapped? |
||||||
after 500 {::punkapp::hide_console} |
after 500 {::punkapp::hide_console} |
||||||
} |
} |
||||||
return $appinfo |
return $appinfo |
||||||
} else { |
} else { |
||||||
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" |
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
|
|
||||||
} |
} |
||||||
|
|
||||||
namespace eval punk::mod::cli { |
namespace eval punk::mod::cli { |
||||||
proc _cli {args} { |
proc _cli {args} { |
||||||
#don't use tailcall - base uses info level to determine caller |
#don't use tailcall - base uses info level to determine caller |
||||||
::punk::mix::base::_cli {*}$args |
::punk::mix::base::_cli {*}$args |
||||||
} |
} |
||||||
variable default_command help |
variable default_command help |
||||||
package require punk::mix::base |
package require punk::mix::base |
||||||
package require punk::overlay |
package require punk::overlay |
||||||
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||||
} |
} |
||||||
|
|
||||||
package provide punk::mod [namespace eval punk::mod { |
package provide punk::mod [namespace eval punk::mod { |
||||||
variable version |
variable version |
||||||
set version 0.1 |
set version 0.1 |
||||||
|
}] |
||||||
}] |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -1,239 +1,239 @@ |
|||||||
#utilities for punk apps to call |
#utilities for punk apps to call |
||||||
|
|
||||||
package provide punkapp [namespace eval punkapp { |
package provide punkapp [namespace eval punkapp { |
||||||
variable version |
variable version |
||||||
set version 0.1 |
set version 0.1 |
||||||
}] |
}] |
||||||
|
|
||||||
namespace eval punkapp { |
namespace eval punkapp { |
||||||
variable result |
variable result |
||||||
variable waiting "no" |
variable waiting "no" |
||||||
proc hide_dot_window {} { |
proc hide_dot_window {} { |
||||||
#alternative to wm withdraw . |
#alternative to wm withdraw . |
||||||
#see https://wiki.tcl-lang.org/page/wm+withdraw |
#see https://wiki.tcl-lang.org/page/wm+withdraw |
||||||
wm geometry . 1x1+0+0 |
wm geometry . 1x1+0+0 |
||||||
wm overrideredirect . 1 |
wm overrideredirect . 1 |
||||||
wm transient . |
wm transient . |
||||||
} |
} |
||||||
proc is_toplevel {w} { |
proc is_toplevel {w} { |
||||||
if {![llength [info commands winfo]]} { |
if {![llength [info commands winfo]]} { |
||||||
return 0 |
return 0 |
||||||
} |
} |
||||||
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} |
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} |
||||||
} |
} |
||||||
proc get_toplevels {{w .}} { |
proc get_toplevels {{w .}} { |
||||||
if {![llength [info commands winfo]]} { |
if {![llength [info commands winfo]]} { |
||||||
return [list] |
return [list] |
||||||
} |
} |
||||||
set list {} |
set list {} |
||||||
if {[is_toplevel $w]} { |
if {[is_toplevel $w]} { |
||||||
lappend list $w |
lappend list $w |
||||||
} |
} |
||||||
foreach w [winfo children $w] { |
foreach w [winfo children $w] { |
||||||
lappend list {*}[get_toplevels $w] |
lappend list {*}[get_toplevels $w] |
||||||
} |
} |
||||||
return $list |
return $list |
||||||
} |
} |
||||||
|
|
||||||
proc make_toplevel_next {prefix} { |
proc make_toplevel_next {prefix} { |
||||||
set top [get_toplevel_next $prefix] |
set top [get_toplevel_next $prefix] |
||||||
return [toplevel $top] |
return [toplevel $top] |
||||||
} |
} |
||||||
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime |
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime |
||||||
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? |
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? |
||||||
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix |
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix |
||||||
proc get_toplevel_next {prefix} { |
proc get_toplevel_next {prefix} { |
||||||
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" |
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
} |
} |
||||||
proc exit {{toplevel ""}} { |
proc exit {{toplevel ""}} { |
||||||
variable waiting |
variable waiting |
||||||
variable result |
variable result |
||||||
variable default_result |
variable default_result |
||||||
set toplevels [get_toplevels] |
set toplevels [get_toplevels] |
||||||
if {[string length $toplevel]} { |
if {[string length $toplevel]} { |
||||||
set wposn [lsearch $toplevels $toplevel] |
set wposn [lsearch $toplevels $toplevel] |
||||||
if {$wposn > 0} { |
if {$wposn > 0} { |
||||||
destroy $toplevel |
destroy $toplevel |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
#review |
#review |
||||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
puts stderr "punkapp::exit called without toplevel - showing console" |
puts stderr "punkapp::exit called without toplevel - showing console" |
||||||
show_console |
show_console |
||||||
return 0 |
return 0 |
||||||
} else { |
} else { |
||||||
puts stderr "punkapp::exit called without toplevel - exiting" |
puts stderr "punkapp::exit called without toplevel - exiting" |
||||||
if {$waiting ne "no"} { |
if {$waiting ne "no"} { |
||||||
if {[info exists result(shell)]} { |
if {[info exists result(shell)]} { |
||||||
set temp [set result(shell)] |
set temp [set result(shell)] |
||||||
unset result(shell) |
unset result(shell) |
||||||
set waiting $temp |
set waiting $temp |
||||||
} else { |
} else { |
||||||
set waiting "" |
set waiting "" |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
::exit |
::exit |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
set controllable [get_user_controllable_toplevels] |
set controllable [get_user_controllable_toplevels] |
||||||
if {![llength $controllable]} { |
if {![llength $controllable]} { |
||||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
show_console |
show_console |
||||||
} else { |
} else { |
||||||
if {$waiting ne "no"} { |
if {$waiting ne "no"} { |
||||||
if {[info exists result(shell)]} { |
if {[info exists result(shell)]} { |
||||||
set temp [set result(shell)] |
set temp [set result(shell)] |
||||||
unset result(shell) |
unset result(shell) |
||||||
set waiting $temp |
set waiting $temp |
||||||
} elseif {[info exists result($toplevel)]} { |
} elseif {[info exists result($toplevel)]} { |
||||||
set temp [set result($toplevel)] |
set temp [set result($toplevel)] |
||||||
unset result($toplevel) |
unset result($toplevel) |
||||||
set waiting $temp |
set waiting $temp |
||||||
} elseif {[info exists default_result]} { |
} elseif {[info exists default_result]} { |
||||||
set temp $default_result |
set temp $default_result |
||||||
unset default_result |
unset default_result |
||||||
set waiting $temp |
set waiting $temp |
||||||
} else { |
} else { |
||||||
set waiting "" |
set waiting "" |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
::exit |
::exit |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
proc close_window {toplevel} { |
proc close_window {toplevel} { |
||||||
wm withdraw $toplevel |
wm withdraw $toplevel |
||||||
if {![llength [get_user_controllable_toplevels]]} { |
if {![llength [get_user_controllable_toplevels]]} { |
||||||
punkapp::exit $toplevel |
punkapp::exit $toplevel |
||||||
} |
} |
||||||
destroy $toplevel |
destroy $toplevel |
||||||
} |
} |
||||||
proc wait {args} { |
proc wait {args} { |
||||||
variable waiting |
variable waiting |
||||||
variable default_result |
variable default_result |
||||||
if {[dict exists $args -defaultresult]} { |
if {[dict exists $args -defaultresult]} { |
||||||
set default_result [dict get $args -defaultresult] |
set default_result [dict get $args -defaultresult] |
||||||
} |
} |
||||||
foreach t [punkapp::get_toplevels] { |
foreach t [punkapp::get_toplevels] { |
||||||
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { |
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { |
||||||
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] |
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] |
||||||
} |
} |
||||||
} |
} |
||||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
puts stderr "repl eventloop seems to be running - punkapp::wait not required" |
puts stderr "repl eventloop seems to be running - punkapp::wait not required" |
||||||
} else { |
} else { |
||||||
if {$waiting eq "no"} { |
if {$waiting eq "no"} { |
||||||
set waiting "waiting" |
set waiting "waiting" |
||||||
vwait ::punkapp::waiting |
vwait ::punkapp::waiting |
||||||
return $::punkapp::waiting |
return $::punkapp::waiting |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
#A window can be 'visible' according to this - but underneath other windows etc |
#A window can be 'visible' according to this - but underneath other windows etc |
||||||
#REVIEW - change name? |
#REVIEW - change name? |
||||||
proc get_visible_toplevels {{w .}} { |
proc get_visible_toplevels {{w .}} { |
||||||
if {![llength [info commands winfo]]} { |
if {![llength [info commands winfo]]} { |
||||||
return [list] |
return [list] |
||||||
} |
} |
||||||
set list [get_toplevels $w] |
set list [get_toplevels $w] |
||||||
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] |
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] |
||||||
set mapped [concat {*}$mapped] ;#ignore {} |
set mapped [concat {*}$mapped] ;#ignore {} |
||||||
set visible [list] |
set visible [list] |
||||||
foreach m $mapped { |
foreach m $mapped { |
||||||
if {[wm overrideredirect $m] == 0 } { |
if {[wm overrideredirect $m] == 0 } { |
||||||
lappend visible $m |
lappend visible $m |
||||||
} else { |
} else { |
||||||
if {[winfo height $m] >1 && [winfo width $m] > 1} { |
if {[winfo height $m] >1 && [winfo width $m] > 1} { |
||||||
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 |
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 |
||||||
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible |
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible |
||||||
lappend visible $m |
lappend visible $m |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
return $visible |
return $visible |
||||||
} |
} |
||||||
proc get_user_controllable_toplevels {{w .}} { |
proc get_user_controllable_toplevels {{w .}} { |
||||||
set visible [get_visible_toplevels $w] |
set visible [get_visible_toplevels $w] |
||||||
set controllable [list] |
set controllable [list] |
||||||
foreach v $visible { |
foreach v $visible { |
||||||
if {[wm overrideredirect $v] == 0} { |
if {[wm overrideredirect $v] == 0} { |
||||||
lappend controllable $v |
lappend controllable $v |
||||||
} |
} |
||||||
} |
} |
||||||
#only return visible windows with overrideredirect == 0 because there exists some user control. |
#only return visible windows with overrideredirect == 0 because there exists some user control. |
||||||
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily |
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily |
||||||
return $controllable |
return $controllable |
||||||
} |
} |
||||||
proc hide_console {args} { |
proc hide_console {args} { |
||||||
set opts [dict create -force 0] |
set opts [dict create -force 0] |
||||||
if {([llength $args] % 2) != 0} { |
if {([llength $args] % 2) != 0} { |
||||||
error "hide_console expects pairs of arguments. e.g -force 1" |
error "hide_console expects pairs of arguments. e.g -force 1" |
||||||
} |
} |
||||||
#set known_opts [dict keys $defaults] |
#set known_opts [dict keys $defaults] |
||||||
foreach {k v} $args { |
foreach {k v} $args { |
||||||
switch -- $k { |
switch -- $k { |
||||||
-force { |
-force { |
||||||
dict set opts $k $v |
dict set opts $k $v |
||||||
} |
} |
||||||
default { |
default { |
||||||
error "Unrecognised options '$k' known options: [dict keys $opts]" |
error "Unrecognised options '$k' known options: [dict keys $opts]" |
||||||
} |
} |
||||||
} |
} |
||||||
} |
} |
||||||
set force [dict get $opts -force] |
set force [dict get $opts -force] |
||||||
|
|
||||||
if {!$force} { |
if {!$force} { |
||||||
if {![llength [get_user_controllable_toplevels]]} { |
if {![llength [get_user_controllable_toplevels]]} { |
||||||
puts stderr "Cannot hide console while no user-controllable windows available" |
puts stderr "Cannot hide console while no user-controllable windows available" |
||||||
return 0 |
return 0 |
||||||
} |
} |
||||||
} |
} |
||||||
if {$::tcl_platform(platform) eq "windows"} { |
if {$::tcl_platform(platform) eq "windows"} { |
||||||
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. |
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. |
||||||
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. |
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. |
||||||
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. |
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. |
||||||
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) |
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) |
||||||
package require twapi |
package require twapi |
||||||
set h [twapi::get_console_window] |
set h [twapi::get_console_window] |
||||||
set pid [twapi::get_window_process $h] |
set pid [twapi::get_window_process $h] |
||||||
set pinfo [twapi::get_process_info $pid -name] |
set pinfo [twapi::get_process_info $pid -name] |
||||||
set pname [dict get $pinfo -name] |
set pname [dict get $pinfo -name] |
||||||
set wstyle [twapi::get_window_style $h] |
set wstyle [twapi::get_window_style $h] |
||||||
#tclkitsh/tclsh? |
#tclkitsh/tclsh? |
||||||
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { |
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { |
||||||
twapi::hide_window $h |
twapi::hide_window $h |
||||||
return 1 |
return 1 |
||||||
} else { |
} else { |
||||||
puts stderr "punkapp::hide_console unable to hide this type of console window" |
puts stderr "punkapp::hide_console unable to hide this type of console window" |
||||||
return 0 |
return 0 |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
#todo |
#todo |
||||||
puts stderr "punkapp::hide_console unimplemented on this platform (todo)" |
puts stderr "punkapp::hide_console unimplemented on this platform (todo)" |
||||||
return 0 |
return 0 |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
proc show_console {} { |
proc show_console {} { |
||||||
if {$::tcl_platform(platform) eq "windows"} { |
if {$::tcl_platform(platform) eq "windows"} { |
||||||
package require twapi |
package require twapi |
||||||
if {![catch {set h [twapi::get_console_window]} errM]} { |
if {![catch {set h [twapi::get_console_window]} errM]} { |
||||||
twapi::show_window $h -activate -normal |
twapi::show_window $h -activate -normal |
||||||
} else { |
} else { |
||||||
#no console - assume launched from something like wish? |
#no console - assume launched from something like wish? |
||||||
catch {console show} |
catch {console show} |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
#todo |
#todo |
||||||
puts stderr "punkapp::show_console unimplemented on this platform" |
puts stderr "punkapp::show_console unimplemented on this platform" |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
} |
} |
||||||
|
|||||||
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
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
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue