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