30 changed files with 15106 additions and 196 deletions
@ -0,0 +1,518 @@ |
|||||||
|
|
||||||
|
|
||||||
|
#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 |
||||||
|
if {$command eq ""} { |
||||||
|
return $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] |
||||||
|
#stack is a list of dicts, 1st entry is token {<cmd> <renamer> <tokenid>} |
||||||
|
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.4 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,628 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2025 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::ansi::sauce 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
tcl::namespace::eval punk::ansi::sauce { |
||||||
|
variable PUNKARGS |
||||||
|
namespace eval argdoc { |
||||||
|
variable PUNKARGS |
||||||
|
#non-colour SGR codes |
||||||
|
set I "\x1b\[3m" ;# [a+ italic] |
||||||
|
set NI "\x1b\[23m" ;# [a+ noitalic] |
||||||
|
set B "\x1b\[1m" ;# [a+ bold] |
||||||
|
set N "\x1b\[22m" ;# [a+ normal] |
||||||
|
set T "\x1b\[1\;4m" ;# [a+ bold underline] |
||||||
|
set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] |
||||||
|
} |
||||||
|
|
||||||
|
proc from_file {fname} { |
||||||
|
if {[file size $fname] < 128} { |
||||||
|
return |
||||||
|
} |
||||||
|
set fd [open $fname r] |
||||||
|
chan conf $fd -translation binary |
||||||
|
chan seek $fd -128 end |
||||||
|
set srec [read $fd] |
||||||
|
set srec_len 128 ;#This is the normal length of a SAUCE record - we may need to set it shorter if truncation detected |
||||||
|
if {[catch {set sdict [to_dict $srec]}]} { |
||||||
|
#review - have seen truncated SAUCE records < 128 bytes |
||||||
|
#we could search for SAUCE00 in the tail and see what records can be parsed? |
||||||
|
#specifically publicdomain roysac images sometimes only 99 Bytes of sauce - suspect remaining were null \x0 padded and trimmed |
||||||
|
set sauceposn [string first SAUCE00 $srec] |
||||||
|
if {$sauceposn <= 0} { |
||||||
|
close $fd |
||||||
|
return |
||||||
|
} |
||||||
|
#emit something to give user an indication something isn't right |
||||||
|
puts stderr "punk::ansi::sauce::from_file WARNING SAUCE record seems to be truncated - padding rhs with nulls and trying again.." |
||||||
|
#SAUCE00 is not at the beginning |
||||||
|
#pad the tail with nulls and try again |
||||||
|
set srec [string range $srec $sauceposn end] |
||||||
|
set srec_len [string length $srec] |
||||||
|
set srec ${srec}[string repeat \x0 [expr {128 - [string length $srec]}]] |
||||||
|
if {[catch {set sdict [to_dict $srec]}]} { |
||||||
|
close $fd |
||||||
|
return |
||||||
|
} |
||||||
|
dict set sdict warning "SAUCE truncation to $srec_len bytes detected" |
||||||
|
} |
||||||
|
if {[dict exists $sdict comments] && [dict get $sdict comments] > 0} { |
||||||
|
set clines [dict get $sdict comments] |
||||||
|
#Use srec_len instead of 128 - in case we had truncated source record which we padded and were able to parse |
||||||
|
set offset [expr {-1 *($srec_len + ($clines * 64) + 5)}] |
||||||
|
chan seek $fd $offset end |
||||||
|
set tag [chan read $fd 5] |
||||||
|
if {$tag eq "COMNT"} { |
||||||
|
#'character' data - shouldn't be null terminated c-style string - but can be |
||||||
|
set commentlines [list] |
||||||
|
for {set c 0} {$c < $clines} {incr c} { |
||||||
|
set rawline [chan read $fd 64] |
||||||
|
set str [lib::get_string $rawline] |
||||||
|
set ln [format %-64s $str] |
||||||
|
|
||||||
|
if {![catch {encoding convertfrom cp437 $ln} line]} { |
||||||
|
lappend commentlines $line |
||||||
|
} else { |
||||||
|
catch { |
||||||
|
package require punk::ansi |
||||||
|
puts stderr "punk::ansi::sauce::from_file failed to decode (from cp437) comment line:[punk::ansi::ansistring VIEW $ln]" |
||||||
|
} |
||||||
|
lappend commentlines [string repeat " " 64] |
||||||
|
} |
||||||
|
} |
||||||
|
dict set sdict commentlines $commentlines |
||||||
|
} |
||||||
|
} |
||||||
|
close $fd |
||||||
|
return $sdict |
||||||
|
} |
||||||
|
|
||||||
|
set datatypes [dict create] |
||||||
|
dict set datatypes 0 none |
||||||
|
dict set datatypes 1 character |
||||||
|
dict set datatypes 2 bitmap |
||||||
|
dict set datatypes 3 vector |
||||||
|
dict set datatypes 4 audio |
||||||
|
dict set datatypes 5 binarytext |
||||||
|
dict set datatypes 6 xbin |
||||||
|
dict set datatypes 7 archive |
||||||
|
dict set datatypes 8 executable |
||||||
|
|
||||||
|
set filetypes [dict create] |
||||||
|
|
||||||
|
#Character |
||||||
|
dict set filetypes 1 0 [list name "ASCII" description "Plain ASCII text file with no formatting codes or color codes."] |
||||||
|
dict set filetypes 1 1 [list name "ANSi" description "A file with ANSi coloring codes and cursor positioning."] |
||||||
|
dict set filetypes 1 2 [list name "ANSiMation" description "Like an ANSi file, but it relies on a fixed screensize."] |
||||||
|
dict set filetypes 1 3 [list name "RIP script" description "Remote Imaging Protocol Graphics."] |
||||||
|
dict set filetypes 1 4 [list name "PCBoard" description "A file with PCBoard color codes and macros, and ANSi codes."] |
||||||
|
dict set filetypes 1 5 [list name "Avatar" description "A file with Avatar color codes, and ANSi codes."] |
||||||
|
dict set filetypes 1 6 [list name "HTML" description "HyperText Markup Language."] |
||||||
|
dict set filetypes 1 7 [list name "Source" description "Source code for some programming language.\nThe file extension should determine the programming language."] |
||||||
|
dict set filetypes 1 8 [list name "TundraDraw" description "A TundraDraw file.\nLike ANSi, but with a custom palette."] |
||||||
|
|
||||||
|
#Bitmap |
||||||
|
dict set filetypes 2 0 [list name "GIF" description "CompuServe Graphics Interchange Format"] |
||||||
|
dict set filetypes 2 1 [list name "PCX" description "ZSoft Paintbrush PCX"] |
||||||
|
dict set filetypes 2 2 [list name "LBM/IFF" description "DeluxePaint LBM/IFF"] |
||||||
|
dict set filetypes 2 3 [list name "TGA" description "Targa Truecolor"] |
||||||
|
dict set filetypes 2 4 [list name "FLI" description "Autodesk FLI animation"] |
||||||
|
dict set filetypes 2 5 [list name "FLC" description "Autodesk FLC animation"] |
||||||
|
dict set filetypes 2 6 [list name "BMP" description "Windows or OS/2 Bitmap"] |
||||||
|
dict set filetypes 2 7 [list name "GL" description "Grasp GL Animation"] |
||||||
|
dict set filetypes 2 8 [list name "DL" description "DL Animation"] |
||||||
|
dict set filetypes 2 9 [list name "WPG" description "Wordperfect Bitmap"] |
||||||
|
dict set filetypes 2 10 [list name "PNG" description "Portable Network Graphics"] |
||||||
|
dict set filetypes 2 11 [list name "JPG/JPeg" description "JPeg image (any subformat)"] |
||||||
|
dict set filetypes 2 12 [list name "MPG" description "MPeg video (any subformat)"] |
||||||
|
dict set filetypes 2 12 [list name "AVI" description "Audio Video Interleave (any subformat)"] |
||||||
|
|
||||||
|
#vector |
||||||
|
dict set filetypes 3 0 [list name "DXF" description "CAD Drawing eXchange Format"] |
||||||
|
dict set filetypes 3 1 [list name "DWG" description "AutoCAD Drawing File"] |
||||||
|
dict set filetypes 3 2 [list name "WPG" description "WordPerfect or DrawPerfect vector graphics"] |
||||||
|
dict set filetypes 3 3 [list name "3DS" description "3D Studio"] |
||||||
|
|
||||||
|
#Audio |
||||||
|
dict set filetypes 4 0 [list name "MOD" description "4, 6 or 8 channel MOD (Noise Tracker)"] |
||||||
|
dict set filetypes 4 1 [list name "669" description "Renaissance 8 channel 669"] |
||||||
|
dict set filetypes 4 2 [list name "STM" description "Future Crew 4 channel ScreamTracker"] |
||||||
|
dict set filetypes 4 3 [list name "S3M" description "Future Crew variable channel ScreamTracker 3"] |
||||||
|
dict set filetypes 4 4 [list name "MTM" description "Renaissance variable channel MultiTracker"] |
||||||
|
dict set filetypes 4 5 [list name "FAR" description "Farandole composer"] |
||||||
|
dict set filetypes 4 6 [list name "ULT" description "UltraTracker"] |
||||||
|
dict set filetypes 4 7 [list name "AMF" description "DMP/DSMI Advanced Module Format"] |
||||||
|
dict set filetypes 4 8 [list name "DMF" description "Delusion Digital Music Format (XTracker)"] |
||||||
|
dict set filetypes 4 9 [list name "OKT" description "Oktalyser"] |
||||||
|
dict set filetypes 4 10 [list name "ROL" description "AdLib ROL file (FM audio)"] |
||||||
|
dict set filetypes 4 11 [list name "CMF" description "Creative Music File (FM Audio)"] |
||||||
|
dict set filetypes 4 12 [list name "MID" description "MIDI (Musical Instrument Digital Interface)"] |
||||||
|
dict set filetypes 4 13 [list name "SADT" description "SAdT composer (FM Audio)"] |
||||||
|
dict set filetypes 4 14 [list name "VOC" description "Creative Voice File"] |
||||||
|
dict set filetypes 4 15 [list name "WAV" description "Waveform Audio File Format"] |
||||||
|
dict set filetypes 4 16 [list name "SMP8" description "Raw, single channel 8 bit sample"] |
||||||
|
dict set filetypes 4 17 [list name "SMP8S" description "Raw, stereo 8 bit sample"] |
||||||
|
dict set filetypes 4 18 [list name "SMP16" description "Raw, single channel 16 bit sample"] |
||||||
|
dict set filetypes 4 19 [list name "SMP16S" description "Raw, stereo 16 bit sample"] |
||||||
|
dict set filetypes 4 20 [list name "PATCH8" description "8 Bit patch file"] |
||||||
|
dict set filetypes 4 21 [list name "PATCH16" description "16 Bit patch file"] |
||||||
|
dict set filetypes 4 22 [list name "XM" description "FastTracker \]\[ module"] |
||||||
|
dict set filetypes 4 23 [list name "HSC" description "HSC Tracker (FM Audio)"] |
||||||
|
dict set filetypes 4 24 [list name "IT" description "Impulse Tracker"] |
||||||
|
|
||||||
|
#Archive |
||||||
|
dict set filetypes 7 0 [list name "ZIP" description "PKWare Zip"] |
||||||
|
dict set filetypes 7 1 [list name "ARJ" description "Archive Robert K. Jung"] |
||||||
|
dict set filetypes 7 2 [list name "LZH" description "Haruyasu Yoshizaki (Yoshi)"] |
||||||
|
dict set filetypes 7 3 [list name "ARC" description "S.E.A"] |
||||||
|
dict set filetypes 7 4 [list name "TAR" description "Unix TAR"] |
||||||
|
dict set filetypes 7 5 [list name "ZOO" description "ZOO"] |
||||||
|
dict set filetypes 7 6 [list name "RAR" description "RAR"] |
||||||
|
dict set filetypes 7 7 [list name "UC2" description "UC2"] |
||||||
|
dict set filetypes 7 8 [list name "PAK" description "PAK"] |
||||||
|
dict set filetypes 7 9 [list name "SQZ" description "SQZ"] |
||||||
|
|
||||||
|
|
||||||
|
#review |
||||||
|
#map sauce encodings to those that exist by default in Tcl 'encoding names' |
||||||
|
set encodings [dict create] |
||||||
|
dict set encodings 437 cp437 |
||||||
|
dict set encodings 720 cp1256 ;#Arabic |
||||||
|
dict set encodings 737 cp737 |
||||||
|
dict set encodings 775 cp775 |
||||||
|
dict set encodings 819 iso8859-1 ;#Latin-1 Supplemental - review |
||||||
|
dict set encodings 850 cp850 |
||||||
|
dict set encodings 852 cp852 |
||||||
|
dict set encodings 855 cp855 |
||||||
|
dict set encodings 857 cp857 |
||||||
|
#dict set encodings 858 "" ;#??? |
||||||
|
dict set encodings 860 cp860 ;#Porguguese |
||||||
|
dict set encodings 861 cp861 ;#Icelandic |
||||||
|
dict set encodings 862 cp862 ;#Hebrew |
||||||
|
dict set encodings 863 cp863 ;#French Canada |
||||||
|
dict set encodings 864 cp864 |
||||||
|
dict set encodings 865 cp865 |
||||||
|
dict set encodings 866 cp866 ;#Cyrillic |
||||||
|
dict set encodings 869 cp869 |
||||||
|
#dict set encodings 872 "" ;#Cyrillic - cp855? macCyrillic? |
||||||
|
#dict set encodings KAM "" ;#cp867,cp895 ? |
||||||
|
#dict set encodings MAZ "" ;#cp667 cp790 ? |
||||||
|
dict set encodings MIK cp866 ;#Cyrillic |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#todo - fontName - which can also specify e.g code page 437 |
||||||
|
## Font name [1] Font size Resolution [2] Aspect ratio [3] Vertical stretch [6] Description |
||||||
|
## Display [4] Pixel [5] |
||||||
|
|
||||||
|
set fontnames [dict create] |
||||||
|
|
||||||
|
## IBM VGA 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Standard hardware font on VGA cards for 80×25 text mode (code page 437) |
||||||
|
dict set fontnames "IBM VGA" [list fontsize "9x16" resolution "720x400" aspect_ratio_display "4:3" aspect_ratio_pixel "20:27 (1:1.35)" vertical_stretch "35%" description "Standard hardware font on VGA cards for 80×25 text mode (code page 437)"] |
||||||
|
## IBM VGA ### [8] 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Software installed code page font for VGA 80×25 text mode |
||||||
|
# - where ### is placeholder for 437,720,737 etc |
||||||
|
|
||||||
|
## IBM VGA50 ### [8] 9×8 [7] 720×400 4:3 20:27 (1:1.35) 35% Software installed code page font for VGA condensed 80×50 text mode |
||||||
|
## IBM VGA25G ### [8] 8×19 640×480 4:3 1:1 0% Custom font for emulating 80×25 in VGA graphics mode 12 (640×480 16 color). |
||||||
|
|
||||||
|
## 8×16 640×400 4:3 6:5 (1:1.2) 20% Modified stats when using an 8 pixel wide version of "IBM VGA" or code page variant. |
||||||
|
## IBM VGA50 9×8 [7] 720×400 4:3 20:27 (1:1.35) 35% Standard hardware font on VGA cards for condensed 80×50 text mode (code page 437) |
||||||
|
## 8×8 640×400 4:3 5:6 (1:1.2) 20% Modified stats when using an 8 pixel wide version of "IBM VGA50" or code page variant. |
||||||
|
## IBM VGA25G 8×19 640×480 4:3 1:1 0% Custom font for emulating 80×25 in VGA graphics mode 12 (640×480 16 color) (code page 437). |
||||||
|
## IBM EGA 8×14 640×350 4:3 35:48 (1:1.3714) 37.14% Standard hardware font on EGA cards for 80×25 text mode (code page 437) |
||||||
|
## IBM EGA43 8×8 640×350 4:3 35:48 (1:1.3714) 37.14% Standard hardware font on EGA cards for condensed 80×43 text mode (code page 437) |
||||||
|
## IBM EGA ### [8] 8×14 640×350 4:3 35:48 (1:1.3714) 37.14% Software installed code page font for EGA 80×25 text mode |
||||||
|
## IBM EGA43 ### [8] 8×8 640×350 4:3 35:48 (1:1.3714) 37.14% Software installed code page font for EGA condensed 80×43 text mode |
||||||
|
## Amiga Topaz 1 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original Amiga Topaz Kickstart 1.x font. (A500, A1000, A2000) |
||||||
|
## Amiga Topaz 1+ 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Modified Amiga Topaz Kickstart 1.x font. (A500, A1000, A2000) |
||||||
|
## Amiga Topaz 2 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original Amiga Topaz Kickstart 2.x font (A600, A1200, A4000) |
||||||
|
## Amiga Topaz 2+ 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Modified Amiga Topaz Kickstart 2.x font (A600, A1200, A4000) |
||||||
|
## Amiga P0T-NOoDLE 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original P0T-NOoDLE font. |
||||||
|
## Amiga MicroKnight 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original MicroKnight font. |
||||||
|
## Amiga MicroKnight+ 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Modified MicroKnight font. |
||||||
|
## Amiga mOsOul 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original mOsOul font. |
||||||
|
## C64 PETSCII unshifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original Commodore PETSCII font (PET, VIC-20, C64, CBM-II, Plus/4, C16, C116 and C128) in the unshifted mode. Unshifted mode (graphics) only has uppercase letters and additional graphic characters. This is the normal boot font. |
||||||
|
## C64 PETSCII shifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original PETSCII font in shifted mode. Shifted mode (text) has both uppercase and lowercase letters. This mode is actuated by pressing Shift+Commodore key. |
||||||
|
## Atari ATASCII 8×8 [11] 320×192 4:3 4:5 (1:1.25) 25% Original ATASCII font (Atari 400, 800, XL, XE) |
||||||
|
|
||||||
|
|
||||||
|
#expect a 128 Byte sauce record |
||||||
|
#Some sauce records may have been padded with null bytes - and been truncated by some process |
||||||
|
|
||||||
|
proc to_dict {saucerecord} { |
||||||
|
variable datatypes |
||||||
|
variable filetypes |
||||||
|
variable encodings |
||||||
|
if {[string length $saucerecord] != 128} { |
||||||
|
error "punk::ansi::sauce::to_dict: Unable to interpret data as a SAUCE record - length != 128" |
||||||
|
} |
||||||
|
if {![string match "SAUCE*" $saucerecord]} { |
||||||
|
error "punk::ansi::sauce::to_dict: Unable to interpret data as a SAUCE record - does not begin with 'SAUCE'" |
||||||
|
} |
||||||
|
#tcl binary scan: cu - unsigned 8-bit, su - unsigned 16-bit, iu - unsigned 32bit, |
||||||
|
set sdict [dict create] |
||||||
|
dict set sdict version [string range $saucerecord 5 6] ;#2bytes |
||||||
|
|
||||||
|
#sauce spec says 'character' type is a string encoded according to code page 437 (IBM PC / OEM ASCII) |
||||||
|
# - in the wild - string may be terminated with null and have following garbage |
||||||
|
# - 'binary scan $rawchars C* str' to get null-terminated string and pad rhs with spaces to cater for this possibility |
||||||
|
#"C" specifier not available in tcl 8.6 |
||||||
|
|
||||||
|
|
||||||
|
#dict set sdict title [string range $saucerecord 7 41] ;#35 bytes 'character' |
||||||
|
set rawtitle [string range $saucerecord 7 41] ;#35 bytes 'character' |
||||||
|
set str [lib::get_string $rawtitle] |
||||||
|
dict set sdict title [format %-35s $str] |
||||||
|
|
||||||
|
#dict set sdict author [string range $saucerecord 42 61] ;#20 bytes 'character' |
||||||
|
set rawauthor [string range $saucerecord 42 61] ;#20 bytes 'character' |
||||||
|
set str [lib::get_string $rawauthor] |
||||||
|
dict set sdict author [format %-20s $str] |
||||||
|
|
||||||
|
#dict set sdict group [string range $saucerecord 62 81] ;#20 bytes 'character' |
||||||
|
set rawgroup [string range $saucerecord 62 81] ;#20 bytes 'character' |
||||||
|
set str [lib::get_string $rawgroup] |
||||||
|
dict set sdict group [format %-20s $str] |
||||||
|
|
||||||
|
|
||||||
|
#dict set sdict date [string range $saucerecord 82 89] ;#8 bytes 'character' |
||||||
|
set rawdate [string range $saucerecord 82 89] ;#8 bytes 'character' |
||||||
|
set str [lib::get_string $rawdate] |
||||||
|
dict set sdict date [format %-8s $str] |
||||||
|
|
||||||
|
|
||||||
|
if {[binary scan [string range $saucerecord 90 93] iu v]} { |
||||||
|
#4 bytes - unsigned littlendian |
||||||
|
dict set sdict filesize $v |
||||||
|
} else { |
||||||
|
dict set sdict filesize "" |
||||||
|
} |
||||||
|
if {[binary scan [string range $saucerecord 94 94] cu v]} { |
||||||
|
#1 byte - unsigned |
||||||
|
dict set sdict datatype $v |
||||||
|
if {[dict exists $datatypes [dict get $sdict datatype]]} { |
||||||
|
dict set sdict datatype_name [dict get $datatypes [dict get $sdict datatype]] |
||||||
|
} else { |
||||||
|
dict set sdict datatype_name unrecognised |
||||||
|
} |
||||||
|
} else { |
||||||
|
dict set sdict datatype "" |
||||||
|
dict set sdict datatype_name failed ;#unrecognised?? |
||||||
|
} |
||||||
|
if {[binary scan [string range $saucerecord 95 95] cu v]} { |
||||||
|
#1 byte - unsigned |
||||||
|
dict set sdict filetype $v |
||||||
|
if {[dict exists $filetypes [dict get $sdict datatype] $v]} { |
||||||
|
dict set sdict filetype_name [dict get $filetypes [dict get $sdict datatype] $v name] |
||||||
|
} else { |
||||||
|
dict set sdict filetype_name "" |
||||||
|
} |
||||||
|
} else { |
||||||
|
dict set sdict filetype "" |
||||||
|
dict set sdict filetype_name "" |
||||||
|
} |
||||||
|
if {[binary scan [string range $saucerecord 96 97] su v]} { |
||||||
|
dict set sdict tinfo1 $v |
||||||
|
} else { |
||||||
|
dict set sdict tinfo1 "" |
||||||
|
} |
||||||
|
|
||||||
|
if {[binary scan [string range $saucerecord 98 99] su v]} { |
||||||
|
dict set sdict tinfo2 $v |
||||||
|
} else { |
||||||
|
dict set sdict tinfo2 "" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {[binary scan [string range $saucerecord 100 101] su v]} { |
||||||
|
dict set sdict tinfo3 $v |
||||||
|
} else { |
||||||
|
dict set sdict tinfo3 "" |
||||||
|
} |
||||||
|
if {[binary scan [string range $saucerecord 102 103] su v]} { |
||||||
|
dict set sdict tinfo4 $v |
||||||
|
} else { |
||||||
|
dict set sdict tinfo4 "" |
||||||
|
} |
||||||
|
if {[binary scan [string range $saucerecord 104 104] cu v]} { |
||||||
|
#1 byte - unsigned |
||||||
|
dict set sdict comments $v |
||||||
|
} else { |
||||||
|
dict set sdict comments 0 |
||||||
|
} |
||||||
|
if {[dict get $sdict datatype_name] in {character binarytext} && [binary scan [string range $saucerecord 105 105] cu v]} { |
||||||
|
dict set sdict tflags $v |
||||||
|
if {$v & 1} { |
||||||
|
dict set sdict ansiflags_ice 1 |
||||||
|
} else { |
||||||
|
dict set sdict ansiflags_ice 0 |
||||||
|
} |
||||||
|
set bits [format %08b $v] |
||||||
|
set ls [string range $bits 5 6] |
||||||
|
switch -- $ls { |
||||||
|
"00" { |
||||||
|
dict set sdict ansiflags_letterspacing unspecified |
||||||
|
} |
||||||
|
"01" { |
||||||
|
dict set sdict ansiflags_letterspacing 8 |
||||||
|
} |
||||||
|
"10" { |
||||||
|
dict set sdict ansiflags_letterspacing 9 |
||||||
|
} |
||||||
|
"11" { |
||||||
|
dict set sdict ansiflags_letterspacing invalid |
||||||
|
} |
||||||
|
} |
||||||
|
set ar [string range $bits 3 4] |
||||||
|
switch -- $ar { |
||||||
|
"00" { |
||||||
|
dict set sdict ansiflags_aspectratio unspecified |
||||||
|
} |
||||||
|
"01" { |
||||||
|
dict set sdict ansiflags_aspectratio tallpixels |
||||||
|
} |
||||||
|
"10" { |
||||||
|
dict set sdict ansiflags_aspectratio squarepixels |
||||||
|
} |
||||||
|
"11" { |
||||||
|
dict set sdict ansiflags_aspectratio invalid |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
dict set sdict tflags "" |
||||||
|
} |
||||||
|
set rawzstring [string range $saucerecord 106 127] |
||||||
|
set str [lib::get_string $rawzstring] |
||||||
|
dict set sdict tinfos $str |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
switch -- [string tolower [dict get $sdict filetype_name]] { |
||||||
|
ansi - ascii - pcboard - avatar { |
||||||
|
dict set sdict columns [dict get $sdict tinfo1] |
||||||
|
dict set sdict rows [dict get $sdict tinfo2] |
||||||
|
dict set sdict fontname [dict get $sdict tinfos] |
||||||
|
} |
||||||
|
ansimation { |
||||||
|
dict set sdict columns [dict get $sdict tinfo1] |
||||||
|
#review - fixed screen height? |
||||||
|
dict set sdict rows [dict get $sdict tinfo2] |
||||||
|
dict set sdict fontname [dict get $sdict tinfos] |
||||||
|
} |
||||||
|
} |
||||||
|
switch -- [dict get $sdict datatype] { |
||||||
|
5 { |
||||||
|
#binarytext |
||||||
|
#filetype is supposed to represent half the characterwidth (only widths with multiples of 2 can be specified) |
||||||
|
#HOWEVER - in the wild we may see width/height specified in tinfo1/tinfo2 with some other value in filetype (eg 1) |
||||||
|
#If both tinfo1 and tinfo2 are non zero - we will use them, even though it's not in spec. |
||||||
|
set t1 [dict get $sdict tinfo1] |
||||||
|
if {$t1 eq ""} { |
||||||
|
set t1 0 |
||||||
|
} |
||||||
|
set t2 [dict get $sdict tinfo2] |
||||||
|
if {$t2 eq ""} { |
||||||
|
set t2 0 |
||||||
|
} |
||||||
|
if {$t1 != 0 && $t2 != 0} { |
||||||
|
#not to spec - but we will assume these have values for a reason.. |
||||||
|
puts stderr "punk::ansi::sauce::to_dict using tinfo1/tinfo2 data for columns/rows (non-compliant SAUCE data)" |
||||||
|
dict set sdict columns [expr {2 * $t1}] |
||||||
|
dict set sdict rows $t2 |
||||||
|
} else { |
||||||
|
#proper mechanism to specify columns for binarytext is the datatype field. |
||||||
|
|
||||||
|
set cols [expr {2*[dict get $sdict filetype]}] |
||||||
|
dict set sdict columns $cols |
||||||
|
#rows must be calculated from file size |
||||||
|
#rows = (filesize - sauceinfosize)/ filetype * 2 * 2 |
||||||
|
#(time additional 2 due to character/attribute pairs) |
||||||
|
|
||||||
|
#todo - calc filesize from total size of file - EOF - comment - sauce rather than rely on stored filesize? |
||||||
|
dict set sdict rows [expr {[dict get $sdict filesize]/($cols * 2)}] |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
6 { |
||||||
|
#xbin - only filtype is 0 |
||||||
|
#https://web.archive.org/web/20120204063040/http://www.acid.org/info/xbin/x_spec.htm |
||||||
|
dict set sdict columns [dict get $sdict tinfo1] |
||||||
|
dict set sdict rows [dict get $sdict tinfo2] |
||||||
|
dict set sdict fontname [dict get $sdict tinfos] |
||||||
|
} |
||||||
|
} |
||||||
|
if {[dict exists $sdict fontname]} { |
||||||
|
set fname [dict get $sdict fontname] |
||||||
|
#IBM VGA and IBM EGA variants are all cp437 - unless a 3 letter code specifying otherwise follows |
||||||
|
switch -- [string range $fname 0 6] { |
||||||
|
"IBM EGA" - "IBM VGA" { |
||||||
|
lassign $fname _ibm _ code |
||||||
|
set cp "" |
||||||
|
if {$code eq ""} { |
||||||
|
set cp "cp437" |
||||||
|
} else { |
||||||
|
if {[dict exists $encodings $code]} { |
||||||
|
set cp [dict get $encodings $code] |
||||||
|
} |
||||||
|
} |
||||||
|
if {$cp ne ""} { |
||||||
|
dict set sdict codepage $cp |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $sdict |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::ansi::sauce::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
|
||||||
|
|
||||||
|
#get_string caters for possible null-terminated strings as these may be seen in the wild even though sauce doesn't specify they should be null-terminated |
||||||
|
if {[catch {binary scan x C v}]} { |
||||||
|
#fallback for tcl 8.6 |
||||||
|
proc get_string {bytes} { |
||||||
|
set cstr [lindex [split $bytes \0] 0] |
||||||
|
binary scan $cstr a* str |
||||||
|
return $str |
||||||
|
} |
||||||
|
} else { |
||||||
|
proc get_string {bytes} { |
||||||
|
binary scan $bytes C* str |
||||||
|
return $str |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#tcl::namespace::eval punk::ansi::sauce::system { |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
# Sample 'about' function with punk::args documentation |
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
tcl::namespace::eval punk::ansi::sauce { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
variable PUNKARGS |
||||||
|
variable PUNKARGS_aliases |
||||||
|
|
||||||
|
lappend PUNKARGS [list { |
||||||
|
@id -id "(package)punk::ansi::sauce" |
||||||
|
@package -name "punk::ansi::sauce" -help\ |
||||||
|
"Basic support for SAUCE format |
||||||
|
Standard Architecture for Universal Comment Extensions |
||||||
|
https://www.acid.org/info/sauce/sauce.htm " |
||||||
|
}] |
||||||
|
|
||||||
|
namespace eval argdoc { |
||||||
|
#namespace for custom argument documentation |
||||||
|
proc package_name {} { |
||||||
|
return punk::ansi::sauce |
||||||
|
} |
||||||
|
proc about_topics {} { |
||||||
|
#info commands results are returned in an arbitrary order (like array keys) |
||||||
|
set topic_funs [info commands [namespace current]::get_topic_*] |
||||||
|
set about_topics [list] |
||||||
|
foreach f $topic_funs { |
||||||
|
set tail [namespace tail $f] |
||||||
|
lappend about_topics [string range $tail [string length get_topic_] end] |
||||||
|
} |
||||||
|
#Adjust this function or 'default_topics' if a different order is required |
||||||
|
return [lsort $about_topics] |
||||||
|
} |
||||||
|
proc default_topics {} {return [list Description *]} |
||||||
|
|
||||||
|
# ------------------------------------------------------------- |
||||||
|
# get_topic_ functions add more to auto-include in about topics |
||||||
|
# ------------------------------------------------------------- |
||||||
|
proc get_topic_Description {} { |
||||||
|
punk::args::lib::tstr [string trim { |
||||||
|
package punk::ansi::sauce |
||||||
|
ANSI SAUCE block processor |
||||||
|
} \n] |
||||||
|
} |
||||||
|
proc get_topic_License {} { |
||||||
|
return "MIT" |
||||||
|
} |
||||||
|
proc get_topic_Version {} { |
||||||
|
return "$::punk::ansi::sauce::version" |
||||||
|
} |
||||||
|
proc get_topic_Contributors {} { |
||||||
|
set authors {{"Julian Noble" <julian@precisium.com.au>}} |
||||||
|
set contributors "" |
||||||
|
foreach a $authors { |
||||||
|
append contributors $a \n |
||||||
|
} |
||||||
|
if {[string index $contributors end] eq "\n"} { |
||||||
|
set contributors [string range $contributors 0 end-1] |
||||||
|
} |
||||||
|
return $contributors |
||||||
|
} |
||||||
|
proc get_topic_custom-topic {} { |
||||||
|
punk::args::lib::tstr -return string { |
||||||
|
A custom |
||||||
|
topic |
||||||
|
etc |
||||||
|
} |
||||||
|
} |
||||||
|
# ------------------------------------------------------------- |
||||||
|
} |
||||||
|
|
||||||
|
# we re-use the argument definition from punk::args::standard_about and override some items |
||||||
|
set overrides [dict create] |
||||||
|
dict set overrides @id -id "::punk::ansi::sauce::about" |
||||||
|
dict set overrides @cmd -name "punk::ansi::sauce::about" |
||||||
|
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||||
|
About punk::ansi::sauce |
||||||
|
}] \n] |
||||||
|
dict set overrides topic -choices [list {*}[punk::ansi::sauce::argdoc::about_topics] *] |
||||||
|
dict set overrides topic -choicerestricted 1 |
||||||
|
dict set overrides topic -default [punk::ansi::sauce::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||||
|
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||||
|
lappend PUNKARGS [list $newdef] |
||||||
|
proc about {args} { |
||||||
|
package require punk::args |
||||||
|
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||||
|
set argd [punk::args::parse $args withid ::punk::ansi::sauce::about] |
||||||
|
lassign [dict values $argd] _leaders opts values _received |
||||||
|
punk::args::package::standard_about -package_about_namespace ::punk::ansi::sauce::argdoc {*}$opts {*}[dict get $values topic] |
||||||
|
} |
||||||
|
} |
||||||
|
# end of sample 'about' function |
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
|
||||||
|
|
||||||
|
# ----------------------------------------------------------------------------- |
||||||
|
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||||
|
# ----------------------------------------------------------------------------- |
||||||
|
# variable PUNKARGS |
||||||
|
# variable PUNKARGS_aliases |
||||||
|
namespace eval ::punk::args::register { |
||||||
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||||
|
lappend ::punk::args::register::NAMESPACES ::punk::ansi::sauce |
||||||
|
} |
||||||
|
# ----------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::ansi::sauce [tcl::namespace::eval punk::ansi::sauce { |
||||||
|
variable pkg punk::ansi::sauce |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
@ -0,0 +1,302 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2025 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::nav::ns 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
tcl::namespace::eval punk::nav::ns { |
||||||
|
variable PUNKARGS |
||||||
|
variable ns_current |
||||||
|
#allow presetting |
||||||
|
if {![info exists ::punk::nav::ns::ns_current]} { |
||||||
|
set ns_current :: |
||||||
|
} |
||||||
|
namespace path {::punk::ns} |
||||||
|
|
||||||
|
proc ns/ {v {ns_or_glob ""} args} { |
||||||
|
variable ns_current ;#change active ns of repl by setting ns_current |
||||||
|
|
||||||
|
set ns_caller [uplevel 1 {::tcl::namespace::current}] |
||||||
|
#puts stderr "ns_cur:$ns_current ns_call:$ns_caller" |
||||||
|
|
||||||
|
|
||||||
|
set types [list all] |
||||||
|
set nspathcommands 0 |
||||||
|
if {$v eq "/"} { |
||||||
|
set types [list children] |
||||||
|
} |
||||||
|
if {$v eq "///"} { |
||||||
|
set nspathcommands 1 |
||||||
|
} |
||||||
|
|
||||||
|
set ns_or_glob [string map {:::: ::} $ns_or_glob] |
||||||
|
|
||||||
|
#todo - cooperate with repl? |
||||||
|
set out "" |
||||||
|
if {$ns_or_glob eq ""} { |
||||||
|
set is_absolute 1 |
||||||
|
set ns_queried $ns_current |
||||||
|
set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] |
||||||
|
} else { |
||||||
|
set is_absolute [string match ::* $ns_or_glob] |
||||||
|
set has_globchars [regexp {[*?]} $ns_or_glob] ;#basic globs only? |
||||||
|
if {$is_absolute} { |
||||||
|
if {!$has_globchars} { |
||||||
|
if {![nsexists $ns_or_glob]} { |
||||||
|
error "cannot change to namespace $ns_or_glob" |
||||||
|
} |
||||||
|
set ns_current $ns_or_glob |
||||||
|
set ns_queried $ns_current |
||||||
|
tailcall ns/ $v "" |
||||||
|
} else { |
||||||
|
set ns_queried $ns_or_glob |
||||||
|
set out [nslist -types $types -nspathcommands $nspathcommands $ns_or_glob] |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {!$has_globchars} { |
||||||
|
set nsnext [nsjoin $ns_current $ns_or_glob] |
||||||
|
if {![nsexists $nsnext]} { |
||||||
|
error "cannot change to namespace $ns_or_glob" |
||||||
|
} |
||||||
|
set ns_current $nsnext |
||||||
|
set ns_queried $nsnext |
||||||
|
set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $nsnext *]] |
||||||
|
} else { |
||||||
|
set ns_queried [nsjoin $ns_current $ns_or_glob] |
||||||
|
set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current $ns_or_glob]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set ns_display "\n$ns_queried" |
||||||
|
if {$ns_current eq $ns_queried} { |
||||||
|
if {$ns_current in [info commands $ns_current] } { |
||||||
|
if {![catch [list tcl::namespace::ensemble configure $ns_current] ensemble_info]} { |
||||||
|
if {[llength $ensemble_info] > 0} { |
||||||
|
#this namespace happens to match ensemble command. |
||||||
|
#todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. |
||||||
|
set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
append out $ns_display |
||||||
|
return $out |
||||||
|
} |
||||||
|
|
||||||
|
#create possibly nested namespace structure - but only if not already existant |
||||||
|
proc n/new {args} { |
||||||
|
variable ns_current |
||||||
|
if {![llength $args]} { |
||||||
|
error "usage: :/new <ns> \[<ns> ...\]" |
||||||
|
} |
||||||
|
set a1 [lindex $args 0] |
||||||
|
set is_absolute [string match ::* $a1] |
||||||
|
if {$is_absolute} { |
||||||
|
set nspath [nsjoinall {*}$args] |
||||||
|
} else { |
||||||
|
if {[string match :* $a1]} { |
||||||
|
puts stderr "n/new WARNING namespace with leading colon '$a1' is likely to have unexpected results" |
||||||
|
} |
||||||
|
set nspath [nsjoinall $ns_current {*}$args] |
||||||
|
} |
||||||
|
|
||||||
|
set ns_exists [nseval [nsprefix $nspath] [list ::tcl::namespace::exists [nstail $nspath] ]] |
||||||
|
|
||||||
|
if {$ns_exists} { |
||||||
|
error "Namespace $nspath already exists" |
||||||
|
} |
||||||
|
#tcl::namespace::eval [nsprefix $nspath] [list tcl::namespace::eval [nstail $nspath] {}] |
||||||
|
nseval [nsprefix $nspath] [list ::tcl::namespace::eval [nstail $nspath] {}] |
||||||
|
n/ $nspath |
||||||
|
} |
||||||
|
|
||||||
|
#nn/ ::/ nsup/ - back up one namespace level |
||||||
|
proc nsup/ {v args} { |
||||||
|
variable ns_current |
||||||
|
if {$ns_current eq "::"} { |
||||||
|
puts stderr "Already at global namespace '::'" |
||||||
|
} else { |
||||||
|
set out "" |
||||||
|
set nsq [nsprefix $ns_current] |
||||||
|
if {$v eq "/"} { |
||||||
|
set out [get_nslist -match [nsjoin $nsq *] -types [list children]] |
||||||
|
} else { |
||||||
|
set out [get_nslist -match [nsjoin $nsq *] -types [list all]] |
||||||
|
} |
||||||
|
#set out [nslist [nsjoin $nsq *]] |
||||||
|
set ns_current $nsq |
||||||
|
append out "\n$ns_current" |
||||||
|
return $out |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#extra slash implies more verbosity (ie display commands instead of just nschildren) |
||||||
|
interp alias {} n/ {} punk::nav::ns::ns/ / |
||||||
|
interp alias {} n// {} punk::nav::ns::ns/ // |
||||||
|
interp alias {} n/// {} punk::nav::ns::ns/ /// |
||||||
|
interp alias {} n/new {} punk::nav::ns::n/new |
||||||
|
interp alias {} nn/ {} punk::nav::ns::nsup/ / |
||||||
|
interp alias {} nn// {} punk::nav::ns::nsup/ // |
||||||
|
if 0 { |
||||||
|
#we can't have ::/ without just plain / which is confusing. |
||||||
|
interp alias {} :/ {} punk::nav::ns::ns/ / |
||||||
|
interp alias {} :// {} punk::nav::ns::ns/ // |
||||||
|
interp alias {} :/new {} punk::nav::ns::n/new |
||||||
|
interp alias {} ::/ {} punk::nav::ns::nsup/ / |
||||||
|
interp alias {} ::// {} punk::nav::ns::nsup/ // |
||||||
|
} |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::nav::ns::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#tcl::namespace::eval punk::nav::ns::system { |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
# Sample 'about' function with punk::args documentation |
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
tcl::namespace::eval punk::nav::ns { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
variable PUNKARGS |
||||||
|
variable PUNKARGS_aliases |
||||||
|
|
||||||
|
lappend PUNKARGS [list { |
||||||
|
@id -id "(package)punk::nav::ns" |
||||||
|
@package -name "punk::nav::ns" -help\ |
||||||
|
"Package |
||||||
|
Description" |
||||||
|
}] |
||||||
|
|
||||||
|
namespace eval argdoc { |
||||||
|
#namespace for custom argument documentation |
||||||
|
proc package_name {} { |
||||||
|
return punk::nav::ns |
||||||
|
} |
||||||
|
proc about_topics {} { |
||||||
|
#info commands results are returned in an arbitrary order (like array keys) |
||||||
|
set topic_funs [info commands [namespace current]::get_topic_*] |
||||||
|
set about_topics [list] |
||||||
|
foreach f $topic_funs { |
||||||
|
set tail [namespace tail $f] |
||||||
|
lappend about_topics [string range $tail [string length get_topic_] end] |
||||||
|
} |
||||||
|
#Adjust this function or 'default_topics' if a different order is required |
||||||
|
return [lsort $about_topics] |
||||||
|
} |
||||||
|
proc default_topics {} {return [list Description *]} |
||||||
|
|
||||||
|
# ------------------------------------------------------------- |
||||||
|
# get_topic_ functions add more to auto-include in about topics |
||||||
|
# ------------------------------------------------------------- |
||||||
|
proc get_topic_Description {} { |
||||||
|
punk::args::lib::tstr [string trim { |
||||||
|
package punk::nav::ns |
||||||
|
description to come.. |
||||||
|
} \n] |
||||||
|
} |
||||||
|
proc get_topic_License {} { |
||||||
|
return "MIT" |
||||||
|
} |
||||||
|
proc get_topic_Version {} { |
||||||
|
return "$::punk::nav::ns::version" |
||||||
|
} |
||||||
|
proc get_topic_Contributors {} { |
||||||
|
set authors {<unspecified>} |
||||||
|
set contributors "" |
||||||
|
foreach a $authors { |
||||||
|
append contributors $a \n |
||||||
|
} |
||||||
|
if {[string index $contributors end] eq "\n"} { |
||||||
|
set contributors [string range $contributors 0 end-1] |
||||||
|
} |
||||||
|
return $contributors |
||||||
|
} |
||||||
|
proc get_topic_custom-topic {} { |
||||||
|
punk::args::lib::tstr -return string { |
||||||
|
A custom |
||||||
|
topic |
||||||
|
etc |
||||||
|
} |
||||||
|
} |
||||||
|
# ------------------------------------------------------------- |
||||||
|
} |
||||||
|
|
||||||
|
# we re-use the argument definition from punk::args::standard_about and override some items |
||||||
|
set overrides [dict create] |
||||||
|
dict set overrides @id -id "::punk::nav::ns::about" |
||||||
|
dict set overrides @cmd -name "punk::nav::ns::about" |
||||||
|
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||||
|
About punk::nav::ns |
||||||
|
}] \n] |
||||||
|
dict set overrides topic -choices [list {*}[punk::nav::ns::argdoc::about_topics] *] |
||||||
|
dict set overrides topic -choicerestricted 1 |
||||||
|
dict set overrides topic -default [punk::nav::ns::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||||
|
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||||
|
lappend PUNKARGS [list $newdef] |
||||||
|
proc about {args} { |
||||||
|
package require punk::args |
||||||
|
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||||
|
set argd [punk::args::parse $args withid ::punk::nav::ns::about] |
||||||
|
lassign [dict values $argd] _leaders opts values _received |
||||||
|
punk::args::package::standard_about -package_about_namespace ::punk::nav::ns::argdoc {*}$opts {*}[dict get $values topic] |
||||||
|
} |
||||||
|
} |
||||||
|
# end of sample 'about' function |
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
|
||||||
|
|
||||||
|
# ----------------------------------------------------------------------------- |
||||||
|
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||||
|
# ----------------------------------------------------------------------------- |
||||||
|
# variable PUNKARGS |
||||||
|
# variable PUNKARGS_aliases |
||||||
|
namespace eval ::punk::args::register { |
||||||
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||||
|
lappend ::punk::args::register::NAMESPACES ::punk::nav::ns |
||||||
|
} |
||||||
|
# ----------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::nav::ns [tcl::namespace::eval punk::nav::ns { |
||||||
|
variable pkg punk::nav::ns |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
@ -0,0 +1,518 @@ |
|||||||
|
|
||||||
|
|
||||||
|
#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 |
||||||
|
if {$command eq ""} { |
||||||
|
return $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] |
||||||
|
#stack is a list of dicts, 1st entry is token {<cmd> <renamer> <tokenid>} |
||||||
|
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.4 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,628 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2025 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::ansi::sauce 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
tcl::namespace::eval punk::ansi::sauce { |
||||||
|
variable PUNKARGS |
||||||
|
namespace eval argdoc { |
||||||
|
variable PUNKARGS |
||||||
|
#non-colour SGR codes |
||||||
|
set I "\x1b\[3m" ;# [a+ italic] |
||||||
|
set NI "\x1b\[23m" ;# [a+ noitalic] |
||||||
|
set B "\x1b\[1m" ;# [a+ bold] |
||||||
|
set N "\x1b\[22m" ;# [a+ normal] |
||||||
|
set T "\x1b\[1\;4m" ;# [a+ bold underline] |
||||||
|
set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] |
||||||
|
} |
||||||
|
|
||||||
|
proc from_file {fname} { |
||||||
|
if {[file size $fname] < 128} { |
||||||
|
return |
||||||
|
} |
||||||
|
set fd [open $fname r] |
||||||
|
chan conf $fd -translation binary |
||||||
|
chan seek $fd -128 end |
||||||
|
set srec [read $fd] |
||||||
|
set srec_len 128 ;#This is the normal length of a SAUCE record - we may need to set it shorter if truncation detected |
||||||
|
if {[catch {set sdict [to_dict $srec]}]} { |
||||||
|
#review - have seen truncated SAUCE records < 128 bytes |
||||||
|
#we could search for SAUCE00 in the tail and see what records can be parsed? |
||||||
|
#specifically publicdomain roysac images sometimes only 99 Bytes of sauce - suspect remaining were null \x0 padded and trimmed |
||||||
|
set sauceposn [string first SAUCE00 $srec] |
||||||
|
if {$sauceposn <= 0} { |
||||||
|
close $fd |
||||||
|
return |
||||||
|
} |
||||||
|
#emit something to give user an indication something isn't right |
||||||
|
puts stderr "punk::ansi::sauce::from_file WARNING SAUCE record seems to be truncated - padding rhs with nulls and trying again.." |
||||||
|
#SAUCE00 is not at the beginning |
||||||
|
#pad the tail with nulls and try again |
||||||
|
set srec [string range $srec $sauceposn end] |
||||||
|
set srec_len [string length $srec] |
||||||
|
set srec ${srec}[string repeat \x0 [expr {128 - [string length $srec]}]] |
||||||
|
if {[catch {set sdict [to_dict $srec]}]} { |
||||||
|
close $fd |
||||||
|
return |
||||||
|
} |
||||||
|
dict set sdict warning "SAUCE truncation to $srec_len bytes detected" |
||||||
|
} |
||||||
|
if {[dict exists $sdict comments] && [dict get $sdict comments] > 0} { |
||||||
|
set clines [dict get $sdict comments] |
||||||
|
#Use srec_len instead of 128 - in case we had truncated source record which we padded and were able to parse |
||||||
|
set offset [expr {-1 *($srec_len + ($clines * 64) + 5)}] |
||||||
|
chan seek $fd $offset end |
||||||
|
set tag [chan read $fd 5] |
||||||
|
if {$tag eq "COMNT"} { |
||||||
|
#'character' data - shouldn't be null terminated c-style string - but can be |
||||||
|
set commentlines [list] |
||||||
|
for {set c 0} {$c < $clines} {incr c} { |
||||||
|
set rawline [chan read $fd 64] |
||||||
|
set str [lib::get_string $rawline] |
||||||
|
set ln [format %-64s $str] |
||||||
|
|
||||||
|
if {![catch {encoding convertfrom cp437 $ln} line]} { |
||||||
|
lappend commentlines $line |
||||||
|
} else { |
||||||
|
catch { |
||||||
|
package require punk::ansi |
||||||
|
puts stderr "punk::ansi::sauce::from_file failed to decode (from cp437) comment line:[punk::ansi::ansistring VIEW $ln]" |
||||||
|
} |
||||||
|
lappend commentlines [string repeat " " 64] |
||||||
|
} |
||||||
|
} |
||||||
|
dict set sdict commentlines $commentlines |
||||||
|
} |
||||||
|
} |
||||||
|
close $fd |
||||||
|
return $sdict |
||||||
|
} |
||||||
|
|
||||||
|
set datatypes [dict create] |
||||||
|
dict set datatypes 0 none |
||||||
|
dict set datatypes 1 character |
||||||
|
dict set datatypes 2 bitmap |
||||||
|
dict set datatypes 3 vector |
||||||
|
dict set datatypes 4 audio |
||||||
|
dict set datatypes 5 binarytext |
||||||
|
dict set datatypes 6 xbin |
||||||
|
dict set datatypes 7 archive |
||||||
|
dict set datatypes 8 executable |
||||||
|
|
||||||
|
set filetypes [dict create] |
||||||
|
|
||||||
|
#Character |
||||||
|
dict set filetypes 1 0 [list name "ASCII" description "Plain ASCII text file with no formatting codes or color codes."] |
||||||
|
dict set filetypes 1 1 [list name "ANSi" description "A file with ANSi coloring codes and cursor positioning."] |
||||||
|
dict set filetypes 1 2 [list name "ANSiMation" description "Like an ANSi file, but it relies on a fixed screensize."] |
||||||
|
dict set filetypes 1 3 [list name "RIP script" description "Remote Imaging Protocol Graphics."] |
||||||
|
dict set filetypes 1 4 [list name "PCBoard" description "A file with PCBoard color codes and macros, and ANSi codes."] |
||||||
|
dict set filetypes 1 5 [list name "Avatar" description "A file with Avatar color codes, and ANSi codes."] |
||||||
|
dict set filetypes 1 6 [list name "HTML" description "HyperText Markup Language."] |
||||||
|
dict set filetypes 1 7 [list name "Source" description "Source code for some programming language.\nThe file extension should determine the programming language."] |
||||||
|
dict set filetypes 1 8 [list name "TundraDraw" description "A TundraDraw file.\nLike ANSi, but with a custom palette."] |
||||||
|
|
||||||
|
#Bitmap |
||||||
|
dict set filetypes 2 0 [list name "GIF" description "CompuServe Graphics Interchange Format"] |
||||||
|
dict set filetypes 2 1 [list name "PCX" description "ZSoft Paintbrush PCX"] |
||||||
|
dict set filetypes 2 2 [list name "LBM/IFF" description "DeluxePaint LBM/IFF"] |
||||||
|
dict set filetypes 2 3 [list name "TGA" description "Targa Truecolor"] |
||||||
|
dict set filetypes 2 4 [list name "FLI" description "Autodesk FLI animation"] |
||||||
|
dict set filetypes 2 5 [list name "FLC" description "Autodesk FLC animation"] |
||||||
|
dict set filetypes 2 6 [list name "BMP" description "Windows or OS/2 Bitmap"] |
||||||
|
dict set filetypes 2 7 [list name "GL" description "Grasp GL Animation"] |
||||||
|
dict set filetypes 2 8 [list name "DL" description "DL Animation"] |
||||||
|
dict set filetypes 2 9 [list name "WPG" description "Wordperfect Bitmap"] |
||||||
|
dict set filetypes 2 10 [list name "PNG" description "Portable Network Graphics"] |
||||||
|
dict set filetypes 2 11 [list name "JPG/JPeg" description "JPeg image (any subformat)"] |
||||||
|
dict set filetypes 2 12 [list name "MPG" description "MPeg video (any subformat)"] |
||||||
|
dict set filetypes 2 12 [list name "AVI" description "Audio Video Interleave (any subformat)"] |
||||||
|
|
||||||
|
#vector |
||||||
|
dict set filetypes 3 0 [list name "DXF" description "CAD Drawing eXchange Format"] |
||||||
|
dict set filetypes 3 1 [list name "DWG" description "AutoCAD Drawing File"] |
||||||
|
dict set filetypes 3 2 [list name "WPG" description "WordPerfect or DrawPerfect vector graphics"] |
||||||
|
dict set filetypes 3 3 [list name "3DS" description "3D Studio"] |
||||||
|
|
||||||
|
#Audio |
||||||
|
dict set filetypes 4 0 [list name "MOD" description "4, 6 or 8 channel MOD (Noise Tracker)"] |
||||||
|
dict set filetypes 4 1 [list name "669" description "Renaissance 8 channel 669"] |
||||||
|
dict set filetypes 4 2 [list name "STM" description "Future Crew 4 channel ScreamTracker"] |
||||||
|
dict set filetypes 4 3 [list name "S3M" description "Future Crew variable channel ScreamTracker 3"] |
||||||
|
dict set filetypes 4 4 [list name "MTM" description "Renaissance variable channel MultiTracker"] |
||||||
|
dict set filetypes 4 5 [list name "FAR" description "Farandole composer"] |
||||||
|
dict set filetypes 4 6 [list name "ULT" description "UltraTracker"] |
||||||
|
dict set filetypes 4 7 [list name "AMF" description "DMP/DSMI Advanced Module Format"] |
||||||
|
dict set filetypes 4 8 [list name "DMF" description "Delusion Digital Music Format (XTracker)"] |
||||||
|
dict set filetypes 4 9 [list name "OKT" description "Oktalyser"] |
||||||
|
dict set filetypes 4 10 [list name "ROL" description "AdLib ROL file (FM audio)"] |
||||||
|
dict set filetypes 4 11 [list name "CMF" description "Creative Music File (FM Audio)"] |
||||||
|
dict set filetypes 4 12 [list name "MID" description "MIDI (Musical Instrument Digital Interface)"] |
||||||
|
dict set filetypes 4 13 [list name "SADT" description "SAdT composer (FM Audio)"] |
||||||
|
dict set filetypes 4 14 [list name "VOC" description "Creative Voice File"] |
||||||
|
dict set filetypes 4 15 [list name "WAV" description "Waveform Audio File Format"] |
||||||
|
dict set filetypes 4 16 [list name "SMP8" description "Raw, single channel 8 bit sample"] |
||||||
|
dict set filetypes 4 17 [list name "SMP8S" description "Raw, stereo 8 bit sample"] |
||||||
|
dict set filetypes 4 18 [list name "SMP16" description "Raw, single channel 16 bit sample"] |
||||||
|
dict set filetypes 4 19 [list name "SMP16S" description "Raw, stereo 16 bit sample"] |
||||||
|
dict set filetypes 4 20 [list name "PATCH8" description "8 Bit patch file"] |
||||||
|
dict set filetypes 4 21 [list name "PATCH16" description "16 Bit patch file"] |
||||||
|
dict set filetypes 4 22 [list name "XM" description "FastTracker \]\[ module"] |
||||||
|
dict set filetypes 4 23 [list name "HSC" description "HSC Tracker (FM Audio)"] |
||||||
|
dict set filetypes 4 24 [list name "IT" description "Impulse Tracker"] |
||||||
|
|
||||||
|
#Archive |
||||||
|
dict set filetypes 7 0 [list name "ZIP" description "PKWare Zip"] |
||||||
|
dict set filetypes 7 1 [list name "ARJ" description "Archive Robert K. Jung"] |
||||||
|
dict set filetypes 7 2 [list name "LZH" description "Haruyasu Yoshizaki (Yoshi)"] |
||||||
|
dict set filetypes 7 3 [list name "ARC" description "S.E.A"] |
||||||
|
dict set filetypes 7 4 [list name "TAR" description "Unix TAR"] |
||||||
|
dict set filetypes 7 5 [list name "ZOO" description "ZOO"] |
||||||
|
dict set filetypes 7 6 [list name "RAR" description "RAR"] |
||||||
|
dict set filetypes 7 7 [list name "UC2" description "UC2"] |
||||||
|
dict set filetypes 7 8 [list name "PAK" description "PAK"] |
||||||
|
dict set filetypes 7 9 [list name "SQZ" description "SQZ"] |
||||||
|
|
||||||
|
|
||||||
|
#review |
||||||
|
#map sauce encodings to those that exist by default in Tcl 'encoding names' |
||||||
|
set encodings [dict create] |
||||||
|
dict set encodings 437 cp437 |
||||||
|
dict set encodings 720 cp1256 ;#Arabic |
||||||
|
dict set encodings 737 cp737 |
||||||
|
dict set encodings 775 cp775 |
||||||
|
dict set encodings 819 iso8859-1 ;#Latin-1 Supplemental - review |
||||||
|
dict set encodings 850 cp850 |
||||||
|
dict set encodings 852 cp852 |
||||||
|
dict set encodings 855 cp855 |
||||||
|
dict set encodings 857 cp857 |
||||||
|
#dict set encodings 858 "" ;#??? |
||||||
|
dict set encodings 860 cp860 ;#Porguguese |
||||||
|
dict set encodings 861 cp861 ;#Icelandic |
||||||
|
dict set encodings 862 cp862 ;#Hebrew |
||||||
|
dict set encodings 863 cp863 ;#French Canada |
||||||
|
dict set encodings 864 cp864 |
||||||
|
dict set encodings 865 cp865 |
||||||
|
dict set encodings 866 cp866 ;#Cyrillic |
||||||
|
dict set encodings 869 cp869 |
||||||
|
#dict set encodings 872 "" ;#Cyrillic - cp855? macCyrillic? |
||||||
|
#dict set encodings KAM "" ;#cp867,cp895 ? |
||||||
|
#dict set encodings MAZ "" ;#cp667 cp790 ? |
||||||
|
dict set encodings MIK cp866 ;#Cyrillic |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#todo - fontName - which can also specify e.g code page 437 |
||||||
|
## Font name [1] Font size Resolution [2] Aspect ratio [3] Vertical stretch [6] Description |
||||||
|
## Display [4] Pixel [5] |
||||||
|
|
||||||
|
set fontnames [dict create] |
||||||
|
|
||||||
|
## IBM VGA 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Standard hardware font on VGA cards for 80×25 text mode (code page 437) |
||||||
|
dict set fontnames "IBM VGA" [list fontsize "9x16" resolution "720x400" aspect_ratio_display "4:3" aspect_ratio_pixel "20:27 (1:1.35)" vertical_stretch "35%" description "Standard hardware font on VGA cards for 80×25 text mode (code page 437)"] |
||||||
|
## IBM VGA ### [8] 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Software installed code page font for VGA 80×25 text mode |
||||||
|
# - where ### is placeholder for 437,720,737 etc |
||||||
|
|
||||||
|
## IBM VGA50 ### [8] 9×8 [7] 720×400 4:3 20:27 (1:1.35) 35% Software installed code page font for VGA condensed 80×50 text mode |
||||||
|
## IBM VGA25G ### [8] 8×19 640×480 4:3 1:1 0% Custom font for emulating 80×25 in VGA graphics mode 12 (640×480 16 color). |
||||||
|
|
||||||
|
## 8×16 640×400 4:3 6:5 (1:1.2) 20% Modified stats when using an 8 pixel wide version of "IBM VGA" or code page variant. |
||||||
|
## IBM VGA50 9×8 [7] 720×400 4:3 20:27 (1:1.35) 35% Standard hardware font on VGA cards for condensed 80×50 text mode (code page 437) |
||||||
|
## 8×8 640×400 4:3 5:6 (1:1.2) 20% Modified stats when using an 8 pixel wide version of "IBM VGA50" or code page variant. |
||||||
|
## IBM VGA25G 8×19 640×480 4:3 1:1 0% Custom font for emulating 80×25 in VGA graphics mode 12 (640×480 16 color) (code page 437). |
||||||
|
## IBM EGA 8×14 640×350 4:3 35:48 (1:1.3714) 37.14% Standard hardware font on EGA cards for 80×25 text mode (code page 437) |
||||||
|
## IBM EGA43 8×8 640×350 4:3 35:48 (1:1.3714) 37.14% Standard hardware font on EGA cards for condensed 80×43 text mode (code page 437) |
||||||
|
## IBM EGA ### [8] 8×14 640×350 4:3 35:48 (1:1.3714) 37.14% Software installed code page font for EGA 80×25 text mode |
||||||
|
## IBM EGA43 ### [8] 8×8 640×350 4:3 35:48 (1:1.3714) 37.14% Software installed code page font for EGA condensed 80×43 text mode |
||||||
|
## Amiga Topaz 1 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original Amiga Topaz Kickstart 1.x font. (A500, A1000, A2000) |
||||||
|
## Amiga Topaz 1+ 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Modified Amiga Topaz Kickstart 1.x font. (A500, A1000, A2000) |
||||||
|
## Amiga Topaz 2 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original Amiga Topaz Kickstart 2.x font (A600, A1200, A4000) |
||||||
|
## Amiga Topaz 2+ 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Modified Amiga Topaz Kickstart 2.x font (A600, A1200, A4000) |
||||||
|
## Amiga P0T-NOoDLE 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original P0T-NOoDLE font. |
||||||
|
## Amiga MicroKnight 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original MicroKnight font. |
||||||
|
## Amiga MicroKnight+ 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Modified MicroKnight font. |
||||||
|
## Amiga mOsOul 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original mOsOul font. |
||||||
|
## C64 PETSCII unshifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original Commodore PETSCII font (PET, VIC-20, C64, CBM-II, Plus/4, C16, C116 and C128) in the unshifted mode. Unshifted mode (graphics) only has uppercase letters and additional graphic characters. This is the normal boot font. |
||||||
|
## C64 PETSCII shifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original PETSCII font in shifted mode. Shifted mode (text) has both uppercase and lowercase letters. This mode is actuated by pressing Shift+Commodore key. |
||||||
|
## Atari ATASCII 8×8 [11] 320×192 4:3 4:5 (1:1.25) 25% Original ATASCII font (Atari 400, 800, XL, XE) |
||||||
|
|
||||||
|
|
||||||
|
#expect a 128 Byte sauce record |
||||||
|
#Some sauce records may have been padded with null bytes - and been truncated by some process |
||||||
|
|
||||||
|
proc to_dict {saucerecord} { |
||||||
|
variable datatypes |
||||||
|
variable filetypes |
||||||
|
variable encodings |
||||||
|
if {[string length $saucerecord] != 128} { |
||||||
|
error "punk::ansi::sauce::to_dict: Unable to interpret data as a SAUCE record - length != 128" |
||||||
|
} |
||||||
|
if {![string match "SAUCE*" $saucerecord]} { |
||||||
|
error "punk::ansi::sauce::to_dict: Unable to interpret data as a SAUCE record - does not begin with 'SAUCE'" |
||||||
|
} |
||||||
|
#tcl binary scan: cu - unsigned 8-bit, su - unsigned 16-bit, iu - unsigned 32bit, |
||||||
|
set sdict [dict create] |
||||||
|
dict set sdict version [string range $saucerecord 5 6] ;#2bytes |
||||||
|
|
||||||
|
#sauce spec says 'character' type is a string encoded according to code page 437 (IBM PC / OEM ASCII) |
||||||
|
# - in the wild - string may be terminated with null and have following garbage |
||||||
|
# - 'binary scan $rawchars C* str' to get null-terminated string and pad rhs with spaces to cater for this possibility |
||||||
|
#"C" specifier not available in tcl 8.6 |
||||||
|
|
||||||
|
|
||||||
|
#dict set sdict title [string range $saucerecord 7 41] ;#35 bytes 'character' |
||||||
|
set rawtitle [string range $saucerecord 7 41] ;#35 bytes 'character' |
||||||
|
set str [lib::get_string $rawtitle] |
||||||
|
dict set sdict title [format %-35s $str] |
||||||
|
|
||||||
|
#dict set sdict author [string range $saucerecord 42 61] ;#20 bytes 'character' |
||||||
|
set rawauthor [string range $saucerecord 42 61] ;#20 bytes 'character' |
||||||
|
set str [lib::get_string $rawauthor] |
||||||
|
dict set sdict author [format %-20s $str] |
||||||
|
|
||||||
|
#dict set sdict group [string range $saucerecord 62 81] ;#20 bytes 'character' |
||||||
|
set rawgroup [string range $saucerecord 62 81] ;#20 bytes 'character' |
||||||
|
set str [lib::get_string $rawgroup] |
||||||
|
dict set sdict group [format %-20s $str] |
||||||
|
|
||||||
|
|
||||||
|
#dict set sdict date [string range $saucerecord 82 89] ;#8 bytes 'character' |
||||||
|
set rawdate [string range $saucerecord 82 89] ;#8 bytes 'character' |
||||||
|
set str [lib::get_string $rawdate] |
||||||
|
dict set sdict date [format %-8s $str] |
||||||
|
|
||||||
|
|
||||||
|
if {[binary scan [string range $saucerecord 90 93] iu v]} { |
||||||
|
#4 bytes - unsigned littlendian |
||||||
|
dict set sdict filesize $v |
||||||
|
} else { |
||||||
|
dict set sdict filesize "" |
||||||
|
} |
||||||
|
if {[binary scan [string range $saucerecord 94 94] cu v]} { |
||||||
|
#1 byte - unsigned |
||||||
|
dict set sdict datatype $v |
||||||
|
if {[dict exists $datatypes [dict get $sdict datatype]]} { |
||||||
|
dict set sdict datatype_name [dict get $datatypes [dict get $sdict datatype]] |
||||||
|
} else { |
||||||
|
dict set sdict datatype_name unrecognised |
||||||
|
} |
||||||
|
} else { |
||||||
|
dict set sdict datatype "" |
||||||
|
dict set sdict datatype_name failed ;#unrecognised?? |
||||||
|
} |
||||||
|
if {[binary scan [string range $saucerecord 95 95] cu v]} { |
||||||
|
#1 byte - unsigned |
||||||
|
dict set sdict filetype $v |
||||||
|
if {[dict exists $filetypes [dict get $sdict datatype] $v]} { |
||||||
|
dict set sdict filetype_name [dict get $filetypes [dict get $sdict datatype] $v name] |
||||||
|
} else { |
||||||
|
dict set sdict filetype_name "" |
||||||
|
} |
||||||
|
} else { |
||||||
|
dict set sdict filetype "" |
||||||
|
dict set sdict filetype_name "" |
||||||
|
} |
||||||
|
if {[binary scan [string range $saucerecord 96 97] su v]} { |
||||||
|
dict set sdict tinfo1 $v |
||||||
|
} else { |
||||||
|
dict set sdict tinfo1 "" |
||||||
|
} |
||||||
|
|
||||||
|
if {[binary scan [string range $saucerecord 98 99] su v]} { |
||||||
|
dict set sdict tinfo2 $v |
||||||
|
} else { |
||||||
|
dict set sdict tinfo2 "" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {[binary scan [string range $saucerecord 100 101] su v]} { |
||||||
|
dict set sdict tinfo3 $v |
||||||
|
} else { |
||||||
|
dict set sdict tinfo3 "" |
||||||
|
} |
||||||
|
if {[binary scan [string range $saucerecord 102 103] su v]} { |
||||||
|
dict set sdict tinfo4 $v |
||||||
|
} else { |
||||||
|
dict set sdict tinfo4 "" |
||||||
|
} |
||||||
|
if {[binary scan [string range $saucerecord 104 104] cu v]} { |
||||||
|
#1 byte - unsigned |
||||||
|
dict set sdict comments $v |
||||||
|
} else { |
||||||
|
dict set sdict comments 0 |
||||||
|
} |
||||||
|
if {[dict get $sdict datatype_name] in {character binarytext} && [binary scan [string range $saucerecord 105 105] cu v]} { |
||||||
|
dict set sdict tflags $v |
||||||
|
if {$v & 1} { |
||||||
|
dict set sdict ansiflags_ice 1 |
||||||
|
} else { |
||||||
|
dict set sdict ansiflags_ice 0 |
||||||
|
} |
||||||
|
set bits [format %08b $v] |
||||||
|
set ls [string range $bits 5 6] |
||||||
|
switch -- $ls { |
||||||
|
"00" { |
||||||
|
dict set sdict ansiflags_letterspacing unspecified |
||||||
|
} |
||||||
|
"01" { |
||||||
|
dict set sdict ansiflags_letterspacing 8 |
||||||
|
} |
||||||
|
"10" { |
||||||
|
dict set sdict ansiflags_letterspacing 9 |
||||||
|
} |
||||||
|
"11" { |
||||||
|
dict set sdict ansiflags_letterspacing invalid |
||||||
|
} |
||||||
|
} |
||||||
|
set ar [string range $bits 3 4] |
||||||
|
switch -- $ar { |
||||||
|
"00" { |
||||||
|
dict set sdict ansiflags_aspectratio unspecified |
||||||
|
} |
||||||
|
"01" { |
||||||
|
dict set sdict ansiflags_aspectratio tallpixels |
||||||
|
} |
||||||
|
"10" { |
||||||
|
dict set sdict ansiflags_aspectratio squarepixels |
||||||
|
} |
||||||
|
"11" { |
||||||
|
dict set sdict ansiflags_aspectratio invalid |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
dict set sdict tflags "" |
||||||
|
} |
||||||
|
set rawzstring [string range $saucerecord 106 127] |
||||||
|
set str [lib::get_string $rawzstring] |
||||||
|
dict set sdict tinfos $str |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
switch -- [string tolower [dict get $sdict filetype_name]] { |
||||||
|
ansi - ascii - pcboard - avatar { |
||||||
|
dict set sdict columns [dict get $sdict tinfo1] |
||||||
|
dict set sdict rows [dict get $sdict tinfo2] |
||||||
|
dict set sdict fontname [dict get $sdict tinfos] |
||||||
|
} |
||||||
|
ansimation { |
||||||
|
dict set sdict columns [dict get $sdict tinfo1] |
||||||
|
#review - fixed screen height? |
||||||
|
dict set sdict rows [dict get $sdict tinfo2] |
||||||
|
dict set sdict fontname [dict get $sdict tinfos] |
||||||
|
} |
||||||
|
} |
||||||
|
switch -- [dict get $sdict datatype] { |
||||||
|
5 { |
||||||
|
#binarytext |
||||||
|
#filetype is supposed to represent half the characterwidth (only widths with multiples of 2 can be specified) |
||||||
|
#HOWEVER - in the wild we may see width/height specified in tinfo1/tinfo2 with some other value in filetype (eg 1) |
||||||
|
#If both tinfo1 and tinfo2 are non zero - we will use them, even though it's not in spec. |
||||||
|
set t1 [dict get $sdict tinfo1] |
||||||
|
if {$t1 eq ""} { |
||||||
|
set t1 0 |
||||||
|
} |
||||||
|
set t2 [dict get $sdict tinfo2] |
||||||
|
if {$t2 eq ""} { |
||||||
|
set t2 0 |
||||||
|
} |
||||||
|
if {$t1 != 0 && $t2 != 0} { |
||||||
|
#not to spec - but we will assume these have values for a reason.. |
||||||
|
puts stderr "punk::ansi::sauce::to_dict using tinfo1/tinfo2 data for columns/rows (non-compliant SAUCE data)" |
||||||
|
dict set sdict columns [expr {2 * $t1}] |
||||||
|
dict set sdict rows $t2 |
||||||
|
} else { |
||||||
|
#proper mechanism to specify columns for binarytext is the datatype field. |
||||||
|
|
||||||
|
set cols [expr {2*[dict get $sdict filetype]}] |
||||||
|
dict set sdict columns $cols |
||||||
|
#rows must be calculated from file size |
||||||
|
#rows = (filesize - sauceinfosize)/ filetype * 2 * 2 |
||||||
|
#(time additional 2 due to character/attribute pairs) |
||||||
|
|
||||||
|
#todo - calc filesize from total size of file - EOF - comment - sauce rather than rely on stored filesize? |
||||||
|
dict set sdict rows [expr {[dict get $sdict filesize]/($cols * 2)}] |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
6 { |
||||||
|
#xbin - only filtype is 0 |
||||||
|
#https://web.archive.org/web/20120204063040/http://www.acid.org/info/xbin/x_spec.htm |
||||||
|
dict set sdict columns [dict get $sdict tinfo1] |
||||||
|
dict set sdict rows [dict get $sdict tinfo2] |
||||||
|
dict set sdict fontname [dict get $sdict tinfos] |
||||||
|
} |
||||||
|
} |
||||||
|
if {[dict exists $sdict fontname]} { |
||||||
|
set fname [dict get $sdict fontname] |
||||||
|
#IBM VGA and IBM EGA variants are all cp437 - unless a 3 letter code specifying otherwise follows |
||||||
|
switch -- [string range $fname 0 6] { |
||||||
|
"IBM EGA" - "IBM VGA" { |
||||||
|
lassign $fname _ibm _ code |
||||||
|
set cp "" |
||||||
|
if {$code eq ""} { |
||||||
|
set cp "cp437" |
||||||
|
} else { |
||||||
|
if {[dict exists $encodings $code]} { |
||||||
|
set cp [dict get $encodings $code] |
||||||
|
} |
||||||
|
} |
||||||
|
if {$cp ne ""} { |
||||||
|
dict set sdict codepage $cp |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $sdict |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::ansi::sauce::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
|
||||||
|
|
||||||
|
#get_string caters for possible null-terminated strings as these may be seen in the wild even though sauce doesn't specify they should be null-terminated |
||||||
|
if {[catch {binary scan x C v}]} { |
||||||
|
#fallback for tcl 8.6 |
||||||
|
proc get_string {bytes} { |
||||||
|
set cstr [lindex [split $bytes \0] 0] |
||||||
|
binary scan $cstr a* str |
||||||
|
return $str |
||||||
|
} |
||||||
|
} else { |
||||||
|
proc get_string {bytes} { |
||||||
|
binary scan $bytes C* str |
||||||
|
return $str |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#tcl::namespace::eval punk::ansi::sauce::system { |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
# Sample 'about' function with punk::args documentation |
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
tcl::namespace::eval punk::ansi::sauce { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
variable PUNKARGS |
||||||
|
variable PUNKARGS_aliases |
||||||
|
|
||||||
|
lappend PUNKARGS [list { |
||||||
|
@id -id "(package)punk::ansi::sauce" |
||||||
|
@package -name "punk::ansi::sauce" -help\ |
||||||
|
"Basic support for SAUCE format |
||||||
|
Standard Architecture for Universal Comment Extensions |
||||||
|
https://www.acid.org/info/sauce/sauce.htm " |
||||||
|
}] |
||||||
|
|
||||||
|
namespace eval argdoc { |
||||||
|
#namespace for custom argument documentation |
||||||
|
proc package_name {} { |
||||||
|
return punk::ansi::sauce |
||||||
|
} |
||||||
|
proc about_topics {} { |
||||||
|
#info commands results are returned in an arbitrary order (like array keys) |
||||||
|
set topic_funs [info commands [namespace current]::get_topic_*] |
||||||
|
set about_topics [list] |
||||||
|
foreach f $topic_funs { |
||||||
|
set tail [namespace tail $f] |
||||||
|
lappend about_topics [string range $tail [string length get_topic_] end] |
||||||
|
} |
||||||
|
#Adjust this function or 'default_topics' if a different order is required |
||||||
|
return [lsort $about_topics] |
||||||
|
} |
||||||
|
proc default_topics {} {return [list Description *]} |
||||||
|
|
||||||
|
# ------------------------------------------------------------- |
||||||
|
# get_topic_ functions add more to auto-include in about topics |
||||||
|
# ------------------------------------------------------------- |
||||||
|
proc get_topic_Description {} { |
||||||
|
punk::args::lib::tstr [string trim { |
||||||
|
package punk::ansi::sauce |
||||||
|
ANSI SAUCE block processor |
||||||
|
} \n] |
||||||
|
} |
||||||
|
proc get_topic_License {} { |
||||||
|
return "MIT" |
||||||
|
} |
||||||
|
proc get_topic_Version {} { |
||||||
|
return "$::punk::ansi::sauce::version" |
||||||
|
} |
||||||
|
proc get_topic_Contributors {} { |
||||||
|
set authors {{"Julian Noble" <julian@precisium.com.au>}} |
||||||
|
set contributors "" |
||||||
|
foreach a $authors { |
||||||
|
append contributors $a \n |
||||||
|
} |
||||||
|
if {[string index $contributors end] eq "\n"} { |
||||||
|
set contributors [string range $contributors 0 end-1] |
||||||
|
} |
||||||
|
return $contributors |
||||||
|
} |
||||||
|
proc get_topic_custom-topic {} { |
||||||
|
punk::args::lib::tstr -return string { |
||||||
|
A custom |
||||||
|
topic |
||||||
|
etc |
||||||
|
} |
||||||
|
} |
||||||
|
# ------------------------------------------------------------- |
||||||
|
} |
||||||
|
|
||||||
|
# we re-use the argument definition from punk::args::standard_about and override some items |
||||||
|
set overrides [dict create] |
||||||
|
dict set overrides @id -id "::punk::ansi::sauce::about" |
||||||
|
dict set overrides @cmd -name "punk::ansi::sauce::about" |
||||||
|
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||||
|
About punk::ansi::sauce |
||||||
|
}] \n] |
||||||
|
dict set overrides topic -choices [list {*}[punk::ansi::sauce::argdoc::about_topics] *] |
||||||
|
dict set overrides topic -choicerestricted 1 |
||||||
|
dict set overrides topic -default [punk::ansi::sauce::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||||
|
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||||
|
lappend PUNKARGS [list $newdef] |
||||||
|
proc about {args} { |
||||||
|
package require punk::args |
||||||
|
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||||
|
set argd [punk::args::parse $args withid ::punk::ansi::sauce::about] |
||||||
|
lassign [dict values $argd] _leaders opts values _received |
||||||
|
punk::args::package::standard_about -package_about_namespace ::punk::ansi::sauce::argdoc {*}$opts {*}[dict get $values topic] |
||||||
|
} |
||||||
|
} |
||||||
|
# end of sample 'about' function |
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
|
||||||
|
|
||||||
|
# ----------------------------------------------------------------------------- |
||||||
|
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||||
|
# ----------------------------------------------------------------------------- |
||||||
|
# variable PUNKARGS |
||||||
|
# variable PUNKARGS_aliases |
||||||
|
namespace eval ::punk::args::register { |
||||||
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||||
|
lappend ::punk::args::register::NAMESPACES ::punk::ansi::sauce |
||||||
|
} |
||||||
|
# ----------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::ansi::sauce [tcl::namespace::eval punk::ansi::sauce { |
||||||
|
variable pkg punk::ansi::sauce |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
@ -0,0 +1,302 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2025 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::nav::ns 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
tcl::namespace::eval punk::nav::ns { |
||||||
|
variable PUNKARGS |
||||||
|
variable ns_current |
||||||
|
#allow presetting |
||||||
|
if {![info exists ::punk::nav::ns::ns_current]} { |
||||||
|
set ns_current :: |
||||||
|
} |
||||||
|
namespace path {::punk::ns} |
||||||
|
|
||||||
|
proc ns/ {v {ns_or_glob ""} args} { |
||||||
|
variable ns_current ;#change active ns of repl by setting ns_current |
||||||
|
|
||||||
|
set ns_caller [uplevel 1 {::tcl::namespace::current}] |
||||||
|
#puts stderr "ns_cur:$ns_current ns_call:$ns_caller" |
||||||
|
|
||||||
|
|
||||||
|
set types [list all] |
||||||
|
set nspathcommands 0 |
||||||
|
if {$v eq "/"} { |
||||||
|
set types [list children] |
||||||
|
} |
||||||
|
if {$v eq "///"} { |
||||||
|
set nspathcommands 1 |
||||||
|
} |
||||||
|
|
||||||
|
set ns_or_glob [string map {:::: ::} $ns_or_glob] |
||||||
|
|
||||||
|
#todo - cooperate with repl? |
||||||
|
set out "" |
||||||
|
if {$ns_or_glob eq ""} { |
||||||
|
set is_absolute 1 |
||||||
|
set ns_queried $ns_current |
||||||
|
set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] |
||||||
|
} else { |
||||||
|
set is_absolute [string match ::* $ns_or_glob] |
||||||
|
set has_globchars [regexp {[*?]} $ns_or_glob] ;#basic globs only? |
||||||
|
if {$is_absolute} { |
||||||
|
if {!$has_globchars} { |
||||||
|
if {![nsexists $ns_or_glob]} { |
||||||
|
error "cannot change to namespace $ns_or_glob" |
||||||
|
} |
||||||
|
set ns_current $ns_or_glob |
||||||
|
set ns_queried $ns_current |
||||||
|
tailcall ns/ $v "" |
||||||
|
} else { |
||||||
|
set ns_queried $ns_or_glob |
||||||
|
set out [nslist -types $types -nspathcommands $nspathcommands $ns_or_glob] |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {!$has_globchars} { |
||||||
|
set nsnext [nsjoin $ns_current $ns_or_glob] |
||||||
|
if {![nsexists $nsnext]} { |
||||||
|
error "cannot change to namespace $ns_or_glob" |
||||||
|
} |
||||||
|
set ns_current $nsnext |
||||||
|
set ns_queried $nsnext |
||||||
|
set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $nsnext *]] |
||||||
|
} else { |
||||||
|
set ns_queried [nsjoin $ns_current $ns_or_glob] |
||||||
|
set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current $ns_or_glob]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set ns_display "\n$ns_queried" |
||||||
|
if {$ns_current eq $ns_queried} { |
||||||
|
if {$ns_current in [info commands $ns_current] } { |
||||||
|
if {![catch [list tcl::namespace::ensemble configure $ns_current] ensemble_info]} { |
||||||
|
if {[llength $ensemble_info] > 0} { |
||||||
|
#this namespace happens to match ensemble command. |
||||||
|
#todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. |
||||||
|
set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
append out $ns_display |
||||||
|
return $out |
||||||
|
} |
||||||
|
|
||||||
|
#create possibly nested namespace structure - but only if not already existant |
||||||
|
proc n/new {args} { |
||||||
|
variable ns_current |
||||||
|
if {![llength $args]} { |
||||||
|
error "usage: :/new <ns> \[<ns> ...\]" |
||||||
|
} |
||||||
|
set a1 [lindex $args 0] |
||||||
|
set is_absolute [string match ::* $a1] |
||||||
|
if {$is_absolute} { |
||||||
|
set nspath [nsjoinall {*}$args] |
||||||
|
} else { |
||||||
|
if {[string match :* $a1]} { |
||||||
|
puts stderr "n/new WARNING namespace with leading colon '$a1' is likely to have unexpected results" |
||||||
|
} |
||||||
|
set nspath [nsjoinall $ns_current {*}$args] |
||||||
|
} |
||||||
|
|
||||||
|
set ns_exists [nseval [nsprefix $nspath] [list ::tcl::namespace::exists [nstail $nspath] ]] |
||||||
|
|
||||||
|
if {$ns_exists} { |
||||||
|
error "Namespace $nspath already exists" |
||||||
|
} |
||||||
|
#tcl::namespace::eval [nsprefix $nspath] [list tcl::namespace::eval [nstail $nspath] {}] |
||||||
|
nseval [nsprefix $nspath] [list ::tcl::namespace::eval [nstail $nspath] {}] |
||||||
|
n/ $nspath |
||||||
|
} |
||||||
|
|
||||||
|
#nn/ ::/ nsup/ - back up one namespace level |
||||||
|
proc nsup/ {v args} { |
||||||
|
variable ns_current |
||||||
|
if {$ns_current eq "::"} { |
||||||
|
puts stderr "Already at global namespace '::'" |
||||||
|
} else { |
||||||
|
set out "" |
||||||
|
set nsq [nsprefix $ns_current] |
||||||
|
if {$v eq "/"} { |
||||||
|
set out [get_nslist -match [nsjoin $nsq *] -types [list children]] |
||||||
|
} else { |
||||||
|
set out [get_nslist -match [nsjoin $nsq *] -types [list all]] |
||||||
|
} |
||||||
|
#set out [nslist [nsjoin $nsq *]] |
||||||
|
set ns_current $nsq |
||||||
|
append out "\n$ns_current" |
||||||
|
return $out |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#extra slash implies more verbosity (ie display commands instead of just nschildren) |
||||||
|
interp alias {} n/ {} punk::nav::ns::ns/ / |
||||||
|
interp alias {} n// {} punk::nav::ns::ns/ // |
||||||
|
interp alias {} n/// {} punk::nav::ns::ns/ /// |
||||||
|
interp alias {} n/new {} punk::nav::ns::n/new |
||||||
|
interp alias {} nn/ {} punk::nav::ns::nsup/ / |
||||||
|
interp alias {} nn// {} punk::nav::ns::nsup/ // |
||||||
|
if 0 { |
||||||
|
#we can't have ::/ without just plain / which is confusing. |
||||||
|
interp alias {} :/ {} punk::nav::ns::ns/ / |
||||||
|
interp alias {} :// {} punk::nav::ns::ns/ // |
||||||
|
interp alias {} :/new {} punk::nav::ns::n/new |
||||||
|
interp alias {} ::/ {} punk::nav::ns::nsup/ / |
||||||
|
interp alias {} ::// {} punk::nav::ns::nsup/ // |
||||||
|
} |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::nav::ns::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#tcl::namespace::eval punk::nav::ns::system { |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
# Sample 'about' function with punk::args documentation |
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
tcl::namespace::eval punk::nav::ns { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
variable PUNKARGS |
||||||
|
variable PUNKARGS_aliases |
||||||
|
|
||||||
|
lappend PUNKARGS [list { |
||||||
|
@id -id "(package)punk::nav::ns" |
||||||
|
@package -name "punk::nav::ns" -help\ |
||||||
|
"Package |
||||||
|
Description" |
||||||
|
}] |
||||||
|
|
||||||
|
namespace eval argdoc { |
||||||
|
#namespace for custom argument documentation |
||||||
|
proc package_name {} { |
||||||
|
return punk::nav::ns |
||||||
|
} |
||||||
|
proc about_topics {} { |
||||||
|
#info commands results are returned in an arbitrary order (like array keys) |
||||||
|
set topic_funs [info commands [namespace current]::get_topic_*] |
||||||
|
set about_topics [list] |
||||||
|
foreach f $topic_funs { |
||||||
|
set tail [namespace tail $f] |
||||||
|
lappend about_topics [string range $tail [string length get_topic_] end] |
||||||
|
} |
||||||
|
#Adjust this function or 'default_topics' if a different order is required |
||||||
|
return [lsort $about_topics] |
||||||
|
} |
||||||
|
proc default_topics {} {return [list Description *]} |
||||||
|
|
||||||
|
# ------------------------------------------------------------- |
||||||
|
# get_topic_ functions add more to auto-include in about topics |
||||||
|
# ------------------------------------------------------------- |
||||||
|
proc get_topic_Description {} { |
||||||
|
punk::args::lib::tstr [string trim { |
||||||
|
package punk::nav::ns |
||||||
|
description to come.. |
||||||
|
} \n] |
||||||
|
} |
||||||
|
proc get_topic_License {} { |
||||||
|
return "MIT" |
||||||
|
} |
||||||
|
proc get_topic_Version {} { |
||||||
|
return "$::punk::nav::ns::version" |
||||||
|
} |
||||||
|
proc get_topic_Contributors {} { |
||||||
|
set authors {<unspecified>} |
||||||
|
set contributors "" |
||||||
|
foreach a $authors { |
||||||
|
append contributors $a \n |
||||||
|
} |
||||||
|
if {[string index $contributors end] eq "\n"} { |
||||||
|
set contributors [string range $contributors 0 end-1] |
||||||
|
} |
||||||
|
return $contributors |
||||||
|
} |
||||||
|
proc get_topic_custom-topic {} { |
||||||
|
punk::args::lib::tstr -return string { |
||||||
|
A custom |
||||||
|
topic |
||||||
|
etc |
||||||
|
} |
||||||
|
} |
||||||
|
# ------------------------------------------------------------- |
||||||
|
} |
||||||
|
|
||||||
|
# we re-use the argument definition from punk::args::standard_about and override some items |
||||||
|
set overrides [dict create] |
||||||
|
dict set overrides @id -id "::punk::nav::ns::about" |
||||||
|
dict set overrides @cmd -name "punk::nav::ns::about" |
||||||
|
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||||
|
About punk::nav::ns |
||||||
|
}] \n] |
||||||
|
dict set overrides topic -choices [list {*}[punk::nav::ns::argdoc::about_topics] *] |
||||||
|
dict set overrides topic -choicerestricted 1 |
||||||
|
dict set overrides topic -default [punk::nav::ns::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||||
|
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||||
|
lappend PUNKARGS [list $newdef] |
||||||
|
proc about {args} { |
||||||
|
package require punk::args |
||||||
|
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||||
|
set argd [punk::args::parse $args withid ::punk::nav::ns::about] |
||||||
|
lassign [dict values $argd] _leaders opts values _received |
||||||
|
punk::args::package::standard_about -package_about_namespace ::punk::nav::ns::argdoc {*}$opts {*}[dict get $values topic] |
||||||
|
} |
||||||
|
} |
||||||
|
# end of sample 'about' function |
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
|
||||||
|
|
||||||
|
# ----------------------------------------------------------------------------- |
||||||
|
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||||
|
# ----------------------------------------------------------------------------- |
||||||
|
# variable PUNKARGS |
||||||
|
# variable PUNKARGS_aliases |
||||||
|
namespace eval ::punk::args::register { |
||||||
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||||
|
lappend ::punk::args::register::NAMESPACES ::punk::nav::ns |
||||||
|
} |
||||||
|
# ----------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::nav::ns [tcl::namespace::eval punk::nav::ns { |
||||||
|
variable pkg punk::nav::ns |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
@ -0,0 +1,53 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Tcl package index file, version 1.1 |
||||||
|
# This file was generated by hand. |
||||||
|
# |
||||||
|
# This will be autogenerated by configure to use the correct name |
||||||
|
# for the vfs dynamic library. |
||||||
|
|
||||||
|
#package ifneeded vfs 1.5.0 [list source [file join $dir vfs.tcl]] |
||||||
|
# |
||||||
|
#package ifneeded starkit 1.3.3 [list source [file join $dir starkit.tcl]] |
||||||
|
# |
||||||
|
## New, for the old, keep version numbers synchronized. |
||||||
|
#package ifneeded vfs::mk4 1.10.1 [list source [file join $dir mk4vfs.tcl]] |
||||||
|
|
||||||
|
|
||||||
|
#2025 - provide a fix for 'bad central header' error in zip::open when platform has older vfs library |
||||||
|
package ifneeded vfs::zip 1.0.4 [list source [file join $dir zipvfs.tcl]] |
||||||
|
|
||||||
|
# New |
||||||
|
#package ifneeded vfs::ftp 1.0 [list source [file join $dir ftpvfs.tcl]] |
||||||
|
#package ifneeded vfs::http 0.6 [list source [file join $dir httpvfs.tcl]] |
||||||
|
#package ifneeded vfs::ns 0.5.1 [list source [file join $dir tclprocvfs.tcl]] |
||||||
|
#package ifneeded vfs::tar 0.91 [list source [file join $dir tarvfs.tcl]] |
||||||
|
#package ifneeded vfs::test 1.0 [list source [file join $dir testvfs.tcl]] |
||||||
|
#package ifneeded vfs::urltype 1.0 [list source [file join $dir vfsUrl.tcl]] |
||||||
|
#package ifneeded vfs::webdav 0.1 [list source [file join $dir webdavvfs.tcl]] |
||||||
|
#package ifneeded vfs::tk 0.5 [list source [file join $dir tkvfs.tcl]] |
||||||
|
## |
||||||
|
## Virtual filesystems based on the template vfs: |
||||||
|
## |
||||||
|
#if {[lsearch -exact $::auto_path [file join $dir template]] < 0} { |
||||||
|
# lappend ::auto_path [file join $dir template] |
||||||
|
#} |
||||||
|
#package ifneeded vfs::template::chroot 1.5.2 \ |
||||||
|
# [list source [file join $dir template chrootvfs.tcl]] |
||||||
|
#package ifneeded vfs::template::collate 1.5.3 \ |
||||||
|
# [list source [file join $dir template collatevfs.tcl]] |
||||||
|
#package ifneeded vfs::template::version 1.5.2 \ |
||||||
|
# [list source [file join $dir template versionvfs.tcl]] |
||||||
|
#package ifneeded vfs::template::version::delta 1.5.2 \ |
||||||
|
# [list source [file join $dir template deltavfs.tcl]] |
||||||
|
#package ifneeded vfs::template::fish 1.5.2 \ |
||||||
|
# [list source [file join $dir template fishvfs.tcl]] |
||||||
|
#package ifneeded vfs::template::quota 1.5.2 \ |
||||||
|
# [list source [file join $dir template quotavfs.tcl]] |
||||||
|
#package ifneeded vfs::template 1.5.5 \ |
||||||
|
# [list source [file join $dir template templatevfs.tcl]] |
||||||
|
## |
||||||
|
## Helpers |
||||||
|
## |
||||||
|
#package ifneeded fileutil::globfind 1.5 \ |
||||||
|
# [list source [file join $dir template globfind.tcl]] |
||||||
|
#package ifneeded trsync 1.0 [list source [file join $dir template tdelta.tcl]] |
||||||
@ -0,0 +1,937 @@ |
|||||||
|
# Removed provision of the backward compatible name. Moved to separate |
||||||
|
# file/package. |
||||||
|
package provide vfs::zip 1.0.4 |
||||||
|
|
||||||
|
package require vfs |
||||||
|
|
||||||
|
# Using the vfs, memchan and Trf extensions, we ought to be able |
||||||
|
# to write a Tcl-only zip virtual filesystem. What we have below |
||||||
|
# is basically that. |
||||||
|
|
||||||
|
namespace eval vfs::zip {} |
||||||
|
|
||||||
|
# Used to execute a zip archive. This is rather like a jar file |
||||||
|
# but simpler. We simply mount it and then source a toplevel |
||||||
|
# file called 'main.tcl'. |
||||||
|
proc vfs::zip::Execute {zipfile} { |
||||||
|
Mount $zipfile $zipfile |
||||||
|
source [file join $zipfile main.tcl] |
||||||
|
} |
||||||
|
|
||||||
|
proc vfs::zip::Mount {zipfile local} { |
||||||
|
set fd [::zip::open [::file normalize $zipfile]] |
||||||
|
vfs::filesystem mount $local [list ::vfs::zip::handler $fd] |
||||||
|
# Register command to unmount |
||||||
|
vfs::RegisterMount $local [list ::vfs::zip::Unmount $fd] |
||||||
|
return $fd |
||||||
|
} |
||||||
|
|
||||||
|
proc vfs::zip::Unmount {fd local} { |
||||||
|
vfs::filesystem unmount $local |
||||||
|
::zip::_close $fd |
||||||
|
} |
||||||
|
|
||||||
|
proc vfs::zip::handler {zipfd cmd root relative actualpath args} { |
||||||
|
#::vfs::log [list $zipfd $cmd $root $relative $actualpath $args] |
||||||
|
if {$cmd == "matchindirectory"} { |
||||||
|
eval [list $cmd $zipfd $relative $actualpath] $args |
||||||
|
} else { |
||||||
|
eval [list $cmd $zipfd $relative] $args |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc vfs::zip::attributes {zipfd} { return [list "state"] } |
||||||
|
proc vfs::zip::state {zipfd args} { |
||||||
|
vfs::attributeCantConfigure "state" "readonly" $args |
||||||
|
} |
||||||
|
|
||||||
|
# If we implement the commands below, we will have a perfect |
||||||
|
# virtual file system for zip files. |
||||||
|
|
||||||
|
proc vfs::zip::matchindirectory {zipfd path actualpath pattern type} { |
||||||
|
#::vfs::log [list matchindirectory $path $actualpath $pattern $type] |
||||||
|
|
||||||
|
# This call to zip::getdir handles empty patterns properly as asking |
||||||
|
# for the existence of a single file $path only |
||||||
|
set res [::zip::getdir $zipfd $path $pattern] |
||||||
|
#::vfs::log "got $res" |
||||||
|
if {![string length $pattern]} { |
||||||
|
if {![::zip::exists $zipfd $path]} { return {} } |
||||||
|
set res [list $actualpath] |
||||||
|
set actualpath "" |
||||||
|
} |
||||||
|
|
||||||
|
set newres [list] |
||||||
|
foreach p [::vfs::matchCorrectTypes $type $res $actualpath] { |
||||||
|
lappend newres [file join $actualpath $p] |
||||||
|
} |
||||||
|
#::vfs::log "got $newres" |
||||||
|
return $newres |
||||||
|
} |
||||||
|
|
||||||
|
proc vfs::zip::stat {zipfd name} { |
||||||
|
#::vfs::log "stat $name" |
||||||
|
::zip::stat $zipfd $name sb |
||||||
|
#::vfs::log [array get sb] |
||||||
|
# remove socket mode file type (0xc000) to prevent Tcl from reporting Fossil archives as socket types |
||||||
|
if {($sb(mode) & 0xf000) == 0xc000} { |
||||||
|
set sb(mode) [expr {$sb(mode) ^ 0xc000}] |
||||||
|
} |
||||||
|
# remove block device bit file type (0x6000) |
||||||
|
if {($sb(mode) & 0xf000) == 0x6000} { |
||||||
|
set sb(mode) [expr {$sb(mode) ^ 0x6000}] |
||||||
|
} |
||||||
|
# remove FIFO mode file type (0x1000) |
||||||
|
if {($sb(mode) & 0xf000) == 0x1000} { |
||||||
|
set sb(mode) [expr {$sb(mode) ^ 0x1000}] |
||||||
|
} |
||||||
|
# remove character device mode file type (0x2000) |
||||||
|
if {($sb(mode) & 0xf000) == 0x2000} { |
||||||
|
set sb(mode) [expr {$sb(mode) ^ 0x2000}] |
||||||
|
} |
||||||
|
# workaround for certain errorneus zip archives |
||||||
|
if {($sb(mode) & 0xffff) == 0xffff} { |
||||||
|
# change to directory type and set mode to 0777 + directory flag |
||||||
|
set sb(mode) 0x41ff |
||||||
|
} |
||||||
|
array get sb |
||||||
|
} |
||||||
|
|
||||||
|
proc vfs::zip::access {zipfd name mode} { |
||||||
|
#::vfs::log "zip-access $name $mode" |
||||||
|
if {$mode & 2} { |
||||||
|
vfs::filesystem posixerror $::vfs::posix(EROFS) |
||||||
|
} |
||||||
|
# Readable, Exists and Executable are treated as 'exists' |
||||||
|
# Could we get more information from the archive? |
||||||
|
if {[::zip::exists $zipfd $name]} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
error "No such file" |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
proc vfs::zip::open {zipfd name mode permissions} { |
||||||
|
#::vfs::log "open $name $mode $permissions" |
||||||
|
# return a list of two elements: |
||||||
|
# 1. first element is the Tcl channel name which has been opened |
||||||
|
# 2. second element (optional) is a command to evaluate when |
||||||
|
# the channel is closed. |
||||||
|
|
||||||
|
switch -- $mode { |
||||||
|
"" - |
||||||
|
"r" { |
||||||
|
if {![::zip::exists $zipfd $name]} { |
||||||
|
vfs::filesystem posixerror $::vfs::posix(ENOENT) |
||||||
|
} |
||||||
|
|
||||||
|
::zip::stat $zipfd $name sb |
||||||
|
|
||||||
|
if {$sb(ino) < 0} { |
||||||
|
vfs::filesystem posixerror $::vfs::posix(EISDIR) |
||||||
|
} |
||||||
|
|
||||||
|
# set nfd [vfs::memchan] |
||||||
|
# fconfigure $nfd -translation binary |
||||||
|
|
||||||
|
seek $zipfd $sb(ino) start |
||||||
|
# set data [zip::Data $zipfd sb 0] |
||||||
|
|
||||||
|
# puts -nonewline $nfd $data |
||||||
|
|
||||||
|
# fconfigure $nfd -translation auto |
||||||
|
# seek $nfd 0 |
||||||
|
# return [list $nfd] |
||||||
|
# use streaming for files larger than 1MB |
||||||
|
if {$::zip::useStreaming && $sb(size) >= 1048576} { |
||||||
|
seek $zipfd [zip::ParseDataHeader $zipfd sb] start |
||||||
|
if { $sb(method) != 0} { |
||||||
|
set nfd [::zip::zstream $zipfd $sb(csize) $sb(size)] |
||||||
|
} else { |
||||||
|
set nfd [::zip::rawstream $zipfd $sb(size)] |
||||||
|
} |
||||||
|
return [list $nfd] |
||||||
|
} else { |
||||||
|
set nfd [vfs::memchan] |
||||||
|
fconfigure $nfd -translation binary |
||||||
|
|
||||||
|
set data [zip::Data $zipfd sb 0] |
||||||
|
|
||||||
|
puts -nonewline $nfd $data |
||||||
|
|
||||||
|
fconfigure $nfd -translation auto |
||||||
|
seek $nfd 0 |
||||||
|
return [list $nfd] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
vfs::filesystem posixerror $::vfs::posix(EROFS) |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc vfs::zip::createdirectory {zipfd name} { |
||||||
|
#::vfs::log "createdirectory $name" |
||||||
|
vfs::filesystem posixerror $::vfs::posix(EROFS) |
||||||
|
} |
||||||
|
|
||||||
|
proc vfs::zip::removedirectory {zipfd name recursive} { |
||||||
|
#::vfs::log "removedirectory $name" |
||||||
|
vfs::filesystem posixerror $::vfs::posix(EROFS) |
||||||
|
} |
||||||
|
|
||||||
|
proc vfs::zip::deletefile {zipfd name} { |
||||||
|
#::vfs::log "deletefile $name" |
||||||
|
vfs::filesystem posixerror $::vfs::posix(EROFS) |
||||||
|
} |
||||||
|
|
||||||
|
proc vfs::zip::fileattributes {zipfd name args} { |
||||||
|
#::vfs::log "fileattributes $args" |
||||||
|
switch -- [llength $args] { |
||||||
|
0 { |
||||||
|
# list strings |
||||||
|
return [list] |
||||||
|
} |
||||||
|
1 { |
||||||
|
# get value |
||||||
|
set index [lindex $args 0] |
||||||
|
return "" |
||||||
|
} |
||||||
|
2 { |
||||||
|
# set value |
||||||
|
set index [lindex $args 0] |
||||||
|
set val [lindex $args 1] |
||||||
|
vfs::filesystem posixerror $::vfs::posix(EROFS) |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc vfs::zip::utime {fd path actime mtime} { |
||||||
|
vfs::filesystem posixerror $::vfs::posix(EROFS) |
||||||
|
} |
||||||
|
|
||||||
|
# Below copied from TclKit distribution |
||||||
|
|
||||||
|
# |
||||||
|
# ZIP decoder: |
||||||
|
# |
||||||
|
# See the ZIP file format specification: |
||||||
|
# http://www.pkware.com/documents/casestudies/APPNOTE.TXT |
||||||
|
# |
||||||
|
# Format of zip file: |
||||||
|
# [ Data ]* [ TOC ]* EndOfArchive |
||||||
|
# |
||||||
|
# Note: TOC is refered to in ZIP doc as "Central Archive" |
||||||
|
# |
||||||
|
# This means there are two ways of accessing: |
||||||
|
# |
||||||
|
# 1) from the begining as a stream - until the header |
||||||
|
# is not "PK\03\04" - ideal for unzipping. |
||||||
|
# |
||||||
|
# 2) for table of contents without reading entire |
||||||
|
# archive by first fetching EndOfArchive, then |
||||||
|
# just loading the TOC |
||||||
|
# |
||||||
|
|
||||||
|
namespace eval zip { |
||||||
|
set zseq 0 |
||||||
|
|
||||||
|
array set methods { |
||||||
|
0 {stored - The file is stored (no compression)} |
||||||
|
1 {shrunk - The file is Shrunk} |
||||||
|
2 {reduce1 - The file is Reduced with compression factor 1} |
||||||
|
3 {reduce2 - The file is Reduced with compression factor 2} |
||||||
|
4 {reduce3 - The file is Reduced with compression factor 3} |
||||||
|
5 {reduce4 - The file is Reduced with compression factor 4} |
||||||
|
6 {implode - The file is Imploded} |
||||||
|
7 {reserved - Reserved for Tokenizing compression algorithm} |
||||||
|
8 {deflate - The file is Deflated} |
||||||
|
9 {reserved - Reserved for enhanced Deflating} |
||||||
|
10 {pkimplode - PKWARE Date Compression Library Imploding} |
||||||
|
11 {reserved - Reserved by PKWARE} |
||||||
|
12 {bzip2 - The file is compressed using BZIP2 algorithm} |
||||||
|
13 {reserved - Reserved by PKWARE} |
||||||
|
14 {lzma - LZMA (EFS)} |
||||||
|
15 {reserved - Reserved by PKWARE} |
||||||
|
} |
||||||
|
# Version types (high-order byte) |
||||||
|
array set systems { |
||||||
|
0 {dos} |
||||||
|
1 {amiga} |
||||||
|
2 {vms} |
||||||
|
3 {unix} |
||||||
|
4 {vm cms} |
||||||
|
5 {atari} |
||||||
|
6 {os/2} |
||||||
|
7 {macos} |
||||||
|
8 {z system 8} |
||||||
|
9 {cp/m} |
||||||
|
10 {tops20} |
||||||
|
11 {windows} |
||||||
|
12 {qdos} |
||||||
|
13 {riscos} |
||||||
|
14 {vfat} |
||||||
|
15 {mvs} |
||||||
|
16 {beos} |
||||||
|
17 {tandem} |
||||||
|
18 {theos} |
||||||
|
} |
||||||
|
# DOS File Attrs |
||||||
|
array set dosattrs { |
||||||
|
1 {readonly} |
||||||
|
2 {hidden} |
||||||
|
4 {system} |
||||||
|
8 {unknown8} |
||||||
|
16 {directory} |
||||||
|
32 {archive} |
||||||
|
64 {unknown64} |
||||||
|
128 {normal} |
||||||
|
} |
||||||
|
|
||||||
|
proc u_short {n} { return [expr { ($n+0x10000)%0x10000 }] } |
||||||
|
} |
||||||
|
|
||||||
|
proc zip::DosTime {date time} { |
||||||
|
set time [u_short $time] |
||||||
|
set date [u_short $date] |
||||||
|
|
||||||
|
# time = fedcba9876543210 |
||||||
|
# HHHHHmmmmmmSSSSS (sec/2 actually) |
||||||
|
|
||||||
|
# data = fedcba9876543210 |
||||||
|
# yyyyyyyMMMMddddd |
||||||
|
|
||||||
|
set sec [expr { ($time & 0x1F) * 2 }] |
||||||
|
set min [expr { ($time >> 5) & 0x3F }] |
||||||
|
set hour [expr { ($time >> 11) & 0x1F }] |
||||||
|
|
||||||
|
set mday [expr { $date & 0x1F }] |
||||||
|
set mon [expr { (($date >> 5) & 0xF) }] |
||||||
|
set year [expr { (($date >> 9) & 0xFF) + 1980 }] |
||||||
|
|
||||||
|
# Fix up bad date/time data, no need to fail |
||||||
|
if {$sec > 59} {set sec 59} |
||||||
|
if {$min > 59} {set min 59} |
||||||
|
if {$hour > 23} {set hour 23} |
||||||
|
if {$mday < 1} {set mday 1} |
||||||
|
if {$mday > 31} {set mday 31} |
||||||
|
if {$mon < 1} {set mon 1} |
||||||
|
if {$mon > 12} {set mon 12} |
||||||
|
|
||||||
|
set res 0 |
||||||
|
catch { |
||||||
|
set dt [format {%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d} \ |
||||||
|
$year $mon $mday $hour $min $sec] |
||||||
|
set res [clock scan $dt -gmt 1] |
||||||
|
} |
||||||
|
|
||||||
|
return $res |
||||||
|
} |
||||||
|
|
||||||
|
proc zip::ParseDataHeader {fd arr {dataVar ""}} { |
||||||
|
upvar 1 $arr sb |
||||||
|
|
||||||
|
upvar 1 $arr sb |
||||||
|
|
||||||
|
# APPNOTE A: Local file header |
||||||
|
set buf [read $fd 30] |
||||||
|
set n [binary scan $buf A4sssssiiiss \ |
||||||
|
hdr sb(ver) sb(flags) sb(method) time date \ |
||||||
|
crc csize size namelen xtralen] |
||||||
|
|
||||||
|
if { ![string equal "PK\03\04" $hdr] } { |
||||||
|
binary scan $hdr H* x |
||||||
|
return -code error "bad header: $x" |
||||||
|
} |
||||||
|
set sb(ver) [expr {$sb(ver) & 0xffff}] |
||||||
|
set sb(flags) [expr {$sb(flags) & 0xffff}] |
||||||
|
set sb(method) [expr {$sb(method) & 0xffff}] |
||||||
|
set sb(mtime) [DosTime $date $time] |
||||||
|
if {!($sb(flags) & (1<<3))} { |
||||||
|
set sb(crc) [expr {$crc & 0xffffffff}] |
||||||
|
set sb(csize) [expr {$csize & 0xffffffff}] |
||||||
|
set sb(size) [expr {$size & 0xffffffff}] |
||||||
|
} |
||||||
|
|
||||||
|
set sb(name) [read $fd [expr {$namelen & 0xffff}]] |
||||||
|
set sb(extra) [read $fd [expr {$xtralen & 0xffff}]] |
||||||
|
if {$sb(flags) & (1 << 11)} { |
||||||
|
set sb(name) [encoding convertfrom utf-8 $sb(name)] |
||||||
|
} |
||||||
|
set sb(name) [string trimleft $sb(name) "./"] |
||||||
|
|
||||||
|
# APPNOTE B: File data |
||||||
|
# if bit 3 of flags is set the csize comes from the central directory |
||||||
|
set offset [tell $fd] |
||||||
|
if {$dataVar != ""} { |
||||||
|
upvar 1 $dataVar data |
||||||
|
set data [read $fd $sb(csize)] |
||||||
|
} else { |
||||||
|
seek $fd $sb(csize) current |
||||||
|
} |
||||||
|
|
||||||
|
# APPNOTE C: Data descriptor |
||||||
|
if { $sb(flags) & (1<<3) } { |
||||||
|
binary scan [read $fd 4] i ddhdr |
||||||
|
if {($ddhdr & 0xffffffff) == 0x08074b50} { |
||||||
|
binary scan [read $fd 12] iii sb(crc) sb(csize) sb(size) |
||||||
|
} else { |
||||||
|
set sb(crc) $ddhdr |
||||||
|
binary scan [read $fd 8] ii sb(csize) sb(size) |
||||||
|
} |
||||||
|
set sb(crc) [expr {$sb(crc) & 0xffffffff}] |
||||||
|
set sb(csize) [expr {$sb(csize) & 0xffffffff}] |
||||||
|
set sb(size) [expr {$sb(size) & 0xffffffff}] |
||||||
|
} |
||||||
|
return $offset |
||||||
|
} |
||||||
|
|
||||||
|
proc zip::Data {fd arr verify} { |
||||||
|
upvar 1 $arr sb |
||||||
|
ParseDataHeader $fd $arr data |
||||||
|
switch -exact -- $sb(method) { |
||||||
|
0 { |
||||||
|
# stored; no compression |
||||||
|
} |
||||||
|
8 { |
||||||
|
# deflated |
||||||
|
if {[catch { |
||||||
|
set data [vfs::zip -mode decompress -nowrap 1 $data] |
||||||
|
} err]} then { |
||||||
|
return -code error "error inflating \"$sb(name)\": $err" |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
set method $sb(method) |
||||||
|
if {[info exists methods($method)]} { |
||||||
|
set method $methods($method) |
||||||
|
} |
||||||
|
return -code error "unsupported compression method |
||||||
|
\"$method\" used for \"$sb(name)\"" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if { $verify && $sb(method) != 0} { |
||||||
|
set ncrc [vfs::crc $data] |
||||||
|
if { ($ncrc & 0xffffffff) != $sb(crc) } { |
||||||
|
vfs::log [format {%s: crc mismatch: expected 0x%x, got 0x%x} \ |
||||||
|
$sb(name) $sb(crc) $ncrc] |
||||||
|
} |
||||||
|
} |
||||||
|
return $data |
||||||
|
} |
||||||
|
|
||||||
|
proc zip::EndOfArchive {fd arr} { |
||||||
|
upvar 1 $arr cb |
||||||
|
|
||||||
|
# [SF Tclvfs Bug 1003574]. Do not seek over beginning of file. |
||||||
|
seek $fd 0 end |
||||||
|
|
||||||
|
# Just looking in the last 512 bytes may be enough to handle zip |
||||||
|
# archives without comments, however for archives which have |
||||||
|
# comments the chunk may start at an arbitrary distance from the |
||||||
|
# end of the file. So if we do not find the header immediately |
||||||
|
# we have to extend the range of our search, possibly until we |
||||||
|
# have a large part of the archive in memory. We can fail only |
||||||
|
# after the whole file has been searched. |
||||||
|
|
||||||
|
set sz [tell $fd] |
||||||
|
if {[info exists ::zip::max_header_seek]} { |
||||||
|
if {$::zip::max_header_seek < $sz} { |
||||||
|
set sz $::zip::max_header_seek |
||||||
|
} |
||||||
|
} |
||||||
|
set len 512 |
||||||
|
set at 512 |
||||||
|
while {1} { |
||||||
|
if {$sz < $at} {set n -$sz} else {set n -$at} |
||||||
|
|
||||||
|
seek $fd $n end |
||||||
|
set hdr [read $fd $len] |
||||||
|
|
||||||
|
# We are using 'string last' as we are searching the first |
||||||
|
# from the end, which is the last from the beginning. See [SF |
||||||
|
# Bug 2256740]. A zip archive stored in a zip archive can |
||||||
|
# confuse the unmodified code, triggering on the magic |
||||||
|
# sequence for the inner, uncompressed archive. |
||||||
|
set pos [string last "PK\05\06" $hdr] |
||||||
|
if {$pos < 0} { |
||||||
|
if {$at >= $sz} { |
||||||
|
return -code error "no header found" |
||||||
|
} |
||||||
|
set len 540 ; # after 1st iteration we force overlap with last buffer |
||||||
|
incr at 512 ; # to ensure that the pattern we look for is not split at |
||||||
|
# ; # a buffer boundary, nor the header itself |
||||||
|
} else { |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set hdrlen [string length $hdr] |
||||||
|
set hdr [string range $hdr [expr $pos + 4] [expr $pos + 21]] |
||||||
|
|
||||||
|
set pos [expr {wide([tell $fd]) + $pos - $hdrlen}] |
||||||
|
|
||||||
|
if {$pos < 0} { |
||||||
|
set pos 0 |
||||||
|
} |
||||||
|
|
||||||
|
binary scan $hdr ssssiis \ |
||||||
|
cb(ndisk) cb(cdisk) \ |
||||||
|
cb(nitems) cb(ntotal) \ |
||||||
|
cb(csize) cb(coff) \ |
||||||
|
cb(comment) |
||||||
|
|
||||||
|
set cb(ndisk) [u_short $cb(ndisk)] |
||||||
|
set cb(nitems) [u_short $cb(nitems)] |
||||||
|
set cb(ntotal) [u_short $cb(ntotal)] |
||||||
|
set cb(comment) [u_short $cb(comment)] |
||||||
|
|
||||||
|
# Compute base for situations where ZIP file |
||||||
|
# has been appended to another media (e.g. EXE) |
||||||
|
set base [expr { $pos - $cb(csize) - $cb(coff) }] |
||||||
|
if {$base < 0} { |
||||||
|
set base 0 |
||||||
|
} |
||||||
|
set cb(base) $base |
||||||
|
|
||||||
|
if {$cb(coff) < 0} { |
||||||
|
set cb(base) [expr {wide($cb(base)) - 4294967296}] |
||||||
|
set cb(coff) [expr {wide($cb(coff)) + 4294967296}] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc zip::TOC {fd arr} { |
||||||
|
upvar #0 zip::$fd cb |
||||||
|
upvar #0 zip::$fd.dir cbdir |
||||||
|
upvar 1 $arr sb |
||||||
|
|
||||||
|
set buf [read $fd 46] |
||||||
|
|
||||||
|
binary scan $buf A4ssssssiiisssssii hdr \ |
||||||
|
sb(vem) sb(ver) sb(flags) sb(method) time date \ |
||||||
|
sb(crc) sb(csize) sb(size) \ |
||||||
|
flen elen clen sb(disk) sb(attr) \ |
||||||
|
sb(atx) sb(ino) |
||||||
|
|
||||||
|
set sb(ino) [expr {$cb(base) + $sb(ino)}] |
||||||
|
|
||||||
|
if { ![string equal "PK\01\02" $hdr] } { |
||||||
|
binary scan $hdr H* x |
||||||
|
return -code error "bad central header: $x" |
||||||
|
} |
||||||
|
|
||||||
|
foreach v {vem ver flags method disk attr} { |
||||||
|
set sb($v) [expr {$sb($v) & 0xffff}] |
||||||
|
} |
||||||
|
set sb(crc) [expr {$sb(crc) & 0xffffffff}] |
||||||
|
set sb(csize) [expr {$sb(csize) & 0xffffffff}] |
||||||
|
set sb(size) [expr {$sb(size) & 0xffffffff}] |
||||||
|
set sb(mtime) [DosTime $date $time] |
||||||
|
set sb(mode) [expr { ($sb(atx) >> 16) & 0xffff }] |
||||||
|
# check atx field or mode field if this is a directory |
||||||
|
if { ((( $sb(atx) & 0xff ) & 16) != 0) || (($sb(mode) & 0x4000) != 0) } { |
||||||
|
set sb(type) directory |
||||||
|
} else { |
||||||
|
set sb(type) file |
||||||
|
} |
||||||
|
set sb(name) [read $fd [u_short $flen]] |
||||||
|
set sb(extra) [read $fd [u_short $elen]] |
||||||
|
set sb(comment) [read $fd [u_short $clen]] |
||||||
|
while {$sb(ino) < 0} { |
||||||
|
set sb(ino) [expr {wide($sb(ino)) + 4294967296}] |
||||||
|
} |
||||||
|
if {$sb(flags) & (1 << 11)} { |
||||||
|
set sb(name) [encoding convertfrom utf-8 $sb(name)] |
||||||
|
set sb(comment) [encoding convertfrom utf-8 $sb(comment)] |
||||||
|
} |
||||||
|
set sb(name) [string trimleft $sb(name) "./"] |
||||||
|
set parent [file dirname $sb(name)] |
||||||
|
if {$parent == "."} {set parent ""} |
||||||
|
lappend cbdir([string tolower $parent]) [file tail [string trimright $sb(name) /]] |
||||||
|
} |
||||||
|
|
||||||
|
proc zip::open {path} { |
||||||
|
#vfs::log [list open $path] |
||||||
|
set fd [::open $path] |
||||||
|
|
||||||
|
if {[catch { |
||||||
|
upvar #0 zip::$fd cb |
||||||
|
upvar #0 zip::$fd.toc toc |
||||||
|
upvar #0 zip::$fd.dir cbdir |
||||||
|
|
||||||
|
fconfigure $fd -translation binary ;#-buffering none |
||||||
|
|
||||||
|
zip::EndOfArchive $fd cb |
||||||
|
|
||||||
|
seek $fd [expr {$cb(base) + $cb(coff)}] start |
||||||
|
|
||||||
|
set toc(_) 0; unset toc(_); #MakeArray |
||||||
|
|
||||||
|
for {set i 0} {$i < $cb(nitems)} {incr i} { |
||||||
|
zip::TOC $fd sb |
||||||
|
|
||||||
|
set origname [string trimright $sb(name) /] |
||||||
|
set sb(depth) [llength [file split $sb(name)]] |
||||||
|
|
||||||
|
set name [string tolower $origname] |
||||||
|
set sba [array get sb] |
||||||
|
set toc($name) $sba |
||||||
|
FAKEDIR toc cbdir [file dirname $origname] |
||||||
|
} |
||||||
|
foreach {n v} [array get cbdir] { |
||||||
|
set cbdir($n) [lsort -unique $v] |
||||||
|
} |
||||||
|
} err]} { |
||||||
|
close $fd |
||||||
|
return -code error $err |
||||||
|
} |
||||||
|
|
||||||
|
return $fd |
||||||
|
} |
||||||
|
|
||||||
|
proc zip::FAKEDIR {tocarr cbdirarr origpath} { |
||||||
|
upvar 1 $tocarr toc $cbdirarr cbdir |
||||||
|
|
||||||
|
set path [string tolower $origpath] |
||||||
|
if { $path == "."} { return } |
||||||
|
|
||||||
|
if { ![info exists toc($path)] } { |
||||||
|
# Implicit directory |
||||||
|
lappend toc($path) \ |
||||||
|
name $origpath \ |
||||||
|
type directory mtime 0 size 0 mode 0777 \ |
||||||
|
ino -1 depth [llength [file split $path]] |
||||||
|
|
||||||
|
set parent [file dirname $path] |
||||||
|
if {$parent == "."} {set parent ""} |
||||||
|
lappend cbdir($parent) [file tail $origpath] |
||||||
|
} |
||||||
|
FAKEDIR toc cbdir [file dirname $origpath] |
||||||
|
} |
||||||
|
|
||||||
|
proc zip::exists {fd path} { |
||||||
|
#::vfs::log "$fd $path" |
||||||
|
if {$path == ""} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
upvar #0 zip::$fd.toc toc |
||||||
|
info exists toc([string tolower $path]) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc zip::stat {fd path arr} { |
||||||
|
upvar #0 zip::$fd.toc toc |
||||||
|
upvar 1 $arr sb |
||||||
|
#vfs::log [list stat $fd $path $arr [info level -1]] |
||||||
|
|
||||||
|
set name [string tolower $path] |
||||||
|
if { $name == "" || $name == "." } { |
||||||
|
array set sb { |
||||||
|
type directory mtime 0 size 0 mode 0777 |
||||||
|
ino -1 depth 0 name "" |
||||||
|
} |
||||||
|
} elseif {![info exists toc($name)] } { |
||||||
|
return -code error "could not read \"$path\": no such file or directory" |
||||||
|
} else { |
||||||
|
array set sb $toc($name) |
||||||
|
} |
||||||
|
set sb(dev) -1 |
||||||
|
set sb(uid) -1 |
||||||
|
set sb(gid) -1 |
||||||
|
set sb(nlink) 1 |
||||||
|
set sb(atime) $sb(mtime) |
||||||
|
set sb(ctime) $sb(mtime) |
||||||
|
return "" |
||||||
|
} |
||||||
|
|
||||||
|
# Treats empty pattern as asking for a particular file only |
||||||
|
proc zip::getdir {fd path {pat *}} { |
||||||
|
#::vfs::log [list getdir $fd $path $pat] |
||||||
|
upvar #0 zip::$fd.toc toc |
||||||
|
upvar #0 zip::$fd.dir cbdir |
||||||
|
|
||||||
|
if { $path == "." || $path == "" } { |
||||||
|
set path "" |
||||||
|
} else { |
||||||
|
set path [string tolower $path] |
||||||
|
} |
||||||
|
|
||||||
|
if {$pat == ""} { |
||||||
|
if {[info exists cbdir($path)]} { |
||||||
|
return [list $path] |
||||||
|
} else { |
||||||
|
return [list] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set rc [list] |
||||||
|
if {[info exists cbdir($path)]} { |
||||||
|
if {$pat == "*"} { |
||||||
|
set rc $cbdir($path) |
||||||
|
} else { |
||||||
|
foreach f $cbdir($path) { |
||||||
|
if {[string match -nocase $pat $f]} { |
||||||
|
lappend rc $f |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $rc |
||||||
|
} |
||||||
|
|
||||||
|
proc zip::_close {fd} { |
||||||
|
variable $fd |
||||||
|
variable $fd.toc |
||||||
|
variable $fd.dir |
||||||
|
unset $fd |
||||||
|
unset $fd.toc |
||||||
|
unset $fd.dir |
||||||
|
::close $fd |
||||||
|
} |
||||||
|
|
||||||
|
# Implementation of stream based decompression for zip |
||||||
|
if {([info commands ::rechan] != "") || ([info commands ::chan] != "")} { |
||||||
|
if {![catch {package require Tcl 8.6}]} { |
||||||
|
# implementation using [zlib stream inflate] and [rechan]/[chan create] |
||||||
|
proc ::zip::zstream_create {fd} { |
||||||
|
upvar #0 ::zip::_zstream_zcmd($fd) zcmd |
||||||
|
if {$zcmd == ""} { |
||||||
|
set zcmd [zlib stream inflate] |
||||||
|
} |
||||||
|
} |
||||||
|
proc ::zip::zstream_delete {fd} { |
||||||
|
upvar #0 ::zip::_zstream_zcmd($fd) zcmd |
||||||
|
if {$zcmd != ""} { |
||||||
|
rename $zcmd "" |
||||||
|
set zcmd "" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::zip::zstream_put {fd data} { |
||||||
|
upvar #0 ::zip::_zstream_zcmd($fd) zcmd |
||||||
|
zstream_create $fd |
||||||
|
$zcmd put $data |
||||||
|
} |
||||||
|
|
||||||
|
proc ::zip::zstream_get {fd} { |
||||||
|
upvar #0 ::zip::_zstream_zcmd($fd) zcmd |
||||||
|
zstream_create $fd |
||||||
|
return [$zcmd get] |
||||||
|
} |
||||||
|
|
||||||
|
set ::zip::useStreaming 1 |
||||||
|
} elseif {![catch {zlib sinflate ::zip::__dummycommand ; rename ::zip::__dummycommand ""}]} { |
||||||
|
proc ::zip::zstream_create {fd} { |
||||||
|
upvar #0 ::zip::_zstream_zcmd($fd) zcmd |
||||||
|
if {$zcmd == ""} { |
||||||
|
set zcmd ::zip::_zstream_cmd_$fd |
||||||
|
zlib sinflate $zcmd |
||||||
|
} |
||||||
|
} |
||||||
|
proc ::zip::zstream_delete {fd} { |
||||||
|
upvar #0 ::zip::_zstream_zcmd($fd) zcmd |
||||||
|
if {$zcmd != ""} { |
||||||
|
rename $zcmd "" |
||||||
|
set zcmd "" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::zip::zstream_put {fd data} { |
||||||
|
upvar #0 ::zip::_zstream_zcmd($fd) zcmd |
||||||
|
zstream_create $fd |
||||||
|
$zcmd fill $data |
||||||
|
} |
||||||
|
|
||||||
|
proc ::zip::zstream_get {fd} { |
||||||
|
upvar #0 ::zip::_zstream_zcmd($fd) zcmd |
||||||
|
zstream_create $fd |
||||||
|
set rc "" |
||||||
|
while {[$zcmd fill] != 0} { |
||||||
|
if {[catch { |
||||||
|
append rc [$zcmd drain 4096] |
||||||
|
}]} { |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
return $rc |
||||||
|
} |
||||||
|
|
||||||
|
set ::zip::useStreaming 1 |
||||||
|
} else { |
||||||
|
set ::zip::useStreaming 0 |
||||||
|
} |
||||||
|
} else { |
||||||
|
set ::zip::useStreaming 0 |
||||||
|
} |
||||||
|
|
||||||
|
proc ::zip::eventClean {fd} { |
||||||
|
variable eventEnable |
||||||
|
eventSet $fd 0 |
||||||
|
} |
||||||
|
|
||||||
|
proc ::zip::eventWatch {fd a} { |
||||||
|
if {[lindex $a 0] == "read"} { |
||||||
|
eventSet $fd 1 |
||||||
|
} else { |
||||||
|
eventSet $fd 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc zip::eventSet {fd e} { |
||||||
|
variable eventEnable |
||||||
|
set cmd [list ::zip:::eventPost $fd] |
||||||
|
after cancel $cmd |
||||||
|
if {$e} { |
||||||
|
set eventEnable($fd) 1 |
||||||
|
after 0 $cmd |
||||||
|
} else { |
||||||
|
catch {unset eventEnable($fd)} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc zip::eventPost {fd} { |
||||||
|
variable eventEnable |
||||||
|
if {[info exists eventEnable($fd)] && $eventEnable($fd)} { |
||||||
|
chan postevent $fd read |
||||||
|
eventSet $fd 1 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::zip::zstream {ifd clen ilen} { |
||||||
|
set start [tell $ifd] |
||||||
|
set cmd [list ::zip::zstream_handler $start $ifd $clen $ilen] |
||||||
|
if {[catch { |
||||||
|
set fd [chan create read $cmd] |
||||||
|
}]} { |
||||||
|
set fd [rechan $cmd 2] |
||||||
|
} |
||||||
|
set ::zip::_zstream_buf($fd) "" |
||||||
|
set ::zip::_zstream_pos($fd) 0 |
||||||
|
set ::zip::_zstream_tell($fd) $start |
||||||
|
set ::zip::_zstream_zcmd($fd) "" |
||||||
|
return $fd |
||||||
|
} |
||||||
|
|
||||||
|
proc ::zip::zstream_handler {istart ifd clen ilen cmd fd {a1 ""} {a2 ""}} { |
||||||
|
upvar #0 ::zip::_zstream_pos($fd) pos |
||||||
|
upvar #0 ::zip::_zstream_buf($fd) buf |
||||||
|
upvar #0 ::zip::_zstream_tell($fd) tell |
||||||
|
upvar #0 ::zip::_zstream_zcmd($fd) zcmd |
||||||
|
switch -- $cmd { |
||||||
|
initialize { |
||||||
|
return [list initialize finalize watch read seek] |
||||||
|
} |
||||||
|
watch { |
||||||
|
eventWatch $fd $a1 |
||||||
|
} |
||||||
|
seek { |
||||||
|
switch $a2 { |
||||||
|
1 - current { incr a1 $pos } |
||||||
|
2 - end { incr a1 $ilen } |
||||||
|
} |
||||||
|
# to seek back, rewind, i.e. start from scratch |
||||||
|
if {$a1 < $pos} { |
||||||
|
zstream_delete $fd |
||||||
|
seek $ifd $istart |
||||||
|
set pos 0 |
||||||
|
set buf "" |
||||||
|
set tell $istart |
||||||
|
} |
||||||
|
|
||||||
|
while {$pos < $a1} { |
||||||
|
set n [expr {$a1 - $pos}] |
||||||
|
if {$n > 4096} { set n 4096 } |
||||||
|
zstream_handler $istart $ifd $clen $ilen read $fd $n |
||||||
|
} |
||||||
|
return $pos |
||||||
|
} |
||||||
|
|
||||||
|
read { |
||||||
|
set r "" |
||||||
|
set n $a1 |
||||||
|
if {$n + $pos > $ilen} { set n [expr {$ilen - $pos}] } |
||||||
|
|
||||||
|
while {$n > 0} { |
||||||
|
set chunk [string range $buf 0 [expr {$n - 1}]] |
||||||
|
set buf [string range $buf $n end] |
||||||
|
incr n -[string length $chunk] |
||||||
|
incr pos [string length $chunk] |
||||||
|
append r $chunk |
||||||
|
|
||||||
|
if {$n > 0} { |
||||||
|
set c [expr {$istart + $clen - [tell $ifd]}] |
||||||
|
if {$c > 4096} { set c 4096 } |
||||||
|
if {$c <= 0} { |
||||||
|
break |
||||||
|
} |
||||||
|
seek $ifd $tell start |
||||||
|
set data [read $ifd $c] |
||||||
|
set tell [tell $ifd] |
||||||
|
zstream_put $fd $data |
||||||
|
while {[string length [set bufdata [zstream_get $fd]]] > 0} { |
||||||
|
append buf $bufdata |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
close - finalize { |
||||||
|
eventClean $fd |
||||||
|
if {$zcmd != ""} { |
||||||
|
rename $zcmd "" |
||||||
|
} |
||||||
|
unset pos |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::zip::rawstream_handler {ifd ioffset ilen cmd fd {a1 ""} {a2 ""} args} { |
||||||
|
upvar ::zip::_rawstream_pos($fd) pos |
||||||
|
switch -- $cmd { |
||||||
|
initialize { |
||||||
|
return [list initialize finalize watch read seek] |
||||||
|
} |
||||||
|
watch { |
||||||
|
eventWatch $fd $a1 |
||||||
|
} |
||||||
|
seek { |
||||||
|
switch $a2 { |
||||||
|
1 - current { incr a1 $pos } |
||||||
|
2 - end { incr a1 $ilen } |
||||||
|
} |
||||||
|
if {$a1 < 0} {set a1 0} |
||||||
|
if {$a1 > $ilen} {set a1 $ilen} |
||||||
|
set pos $a1 |
||||||
|
return $pos |
||||||
|
} |
||||||
|
read { |
||||||
|
seek $ifd $ioffset |
||||||
|
seek $ifd $pos current |
||||||
|
set n $a1 |
||||||
|
if {$n + $pos > $ilen} { set n [expr {$ilen - $pos}] } |
||||||
|
set fc [read $ifd $n] |
||||||
|
incr pos [string length $fc] |
||||||
|
return $fc |
||||||
|
} |
||||||
|
close - finalize { |
||||||
|
eventClean $fd |
||||||
|
unset pos |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::zip::rawstream {ifd ilen} { |
||||||
|
set cname _rawstream_[incr ::zip::zseq] |
||||||
|
set start [tell $ifd] |
||||||
|
set cmd [list ::zip::rawstream_handler $ifd $start $ilen] |
||||||
|
if {[catch { |
||||||
|
set fd [chan create read $cmd] |
||||||
|
}]} { |
||||||
|
set fd [rechan $cmd 2] |
||||||
|
} |
||||||
|
set ::zip::_rawstream_pos($fd) 0 |
||||||
|
return $fd |
||||||
|
} |
||||||
|
|
||||||
@ -0,0 +1,518 @@ |
|||||||
|
|
||||||
|
|
||||||
|
#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 |
||||||
|
if {$command eq ""} { |
||||||
|
return $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] |
||||||
|
#stack is a list of dicts, 1st entry is token {<cmd> <renamer> <tokenid>} |
||||||
|
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.4 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
Loading…
Reference in new issue