From 877e8df9ad06acc7bdc56307562b0b3f4e7dc80b Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Thu, 4 Jun 2026 22:20:19 +1000 Subject: [PATCH] change some module filenames for better version control, basic xbin support in overtype --- .../zipper-999999.0a1.0.tm | 3 +- src/modules/commandstack-999999.0a1.0.tm | 525 ++++++++++++++++++ src/modules/commandstack-buildversion.txt | 3 + src/modules/funcl-0.1.tm | 11 +- ...ort-0.1.1.6.tm => natsort-999999.0a1.0.tm} | 314 +++++------ src/modules/natsort-buildversion.txt | 3 + .../{oolib-0.1.2.tm => oolib-999999.0a1.0.tm} | 11 +- src/modules/oolib-buildversion.txt | 3 + src/modules/overtype-999999.0a1.0.tm | 170 +++++- ...unk-1.1.tm => patternpunk-999999.0a1.0.tm} | 4 +- src/modules/patternpunk-buildversion.txt | 3 + .../{punk-0.1.tm => punk-999999.0a1.0.tm} | 6 +- src/modules/punk-buildversion.txt | 3 + src/modules/punk/ansi-999999.0a1.0.tm | 151 ++++- src/modules/punk/ansi/sauce-999999.0a1.0.tm | 21 +- src/modules/punk/console-999999.0a1.0.tm | 5 - src/modules/punk/du-999999.0a1.0.tm | 33 +- .../mix/commandset/loadedlib-999999.0a1.0.tm | 11 - .../punk/{mod-0.1.tm => mod-999999.0a1.0.tm} | 5 +- src/modules/punk/mod-buildversion.txt | 3 + src/modules/punk/nav/fs-999999.0a1.0.tm | 2 +- ...overlay-0.1.tm => overlay-999999.0a1.0.tm} | 3 +- src/modules/punk/overlay-buildversion.txt | 3 + src/modules/punk/repl-999999.0a1.0.tm | 24 +- src/modules/punk/repo-999999.0a1.0.tm | 3 +- ...punkapp-0.1.tm => punkapp-999999.0a1.0.tm} | 9 +- src/modules/punkapp-buildversion.txt | 3 + ...eck-0.1.0.tm => punkcheck-999999.0a1.0.tm} | 2 +- src/modules/punkcheck-buildversion.txt | 3 + src/modules/punkcheck/cli-999999.0a1.0.tm | 32 +- ...lrun-0.1.1.tm => shellrun-999999.0a1.0.tm} | 2 +- src/modules/shellrun-buildversion.txt | 3 + src/modules/textblock-999999.0a1.0.tm | 127 +++-- src/modules/zzzload-999999.0a1.0.tm | 25 +- 34 files changed, 1164 insertions(+), 365 deletions(-) create mode 100644 src/modules/commandstack-999999.0a1.0.tm create mode 100644 src/modules/commandstack-buildversion.txt rename src/modules/{natsort-0.1.1.6.tm => natsort-999999.0a1.0.tm} (94%) create mode 100644 src/modules/natsort-buildversion.txt rename src/modules/{oolib-0.1.2.tm => oolib-999999.0a1.0.tm} (99%) create mode 100644 src/modules/oolib-buildversion.txt rename src/modules/{patternpunk-1.1.tm => patternpunk-999999.0a1.0.tm} (99%) create mode 100644 src/modules/patternpunk-buildversion.txt rename src/modules/{punk-0.1.tm => punk-999999.0a1.0.tm} (99%) create mode 100644 src/modules/punk-buildversion.txt rename src/modules/punk/{mod-0.1.tm => mod-999999.0a1.0.tm} (99%) create mode 100644 src/modules/punk/mod-buildversion.txt rename src/modules/punk/{overlay-0.1.tm => overlay-999999.0a1.0.tm} (99%) create mode 100644 src/modules/punk/overlay-buildversion.txt rename src/modules/{punkapp-0.1.tm => punkapp-999999.0a1.0.tm} (99%) create mode 100644 src/modules/punkapp-buildversion.txt rename src/modules/{punkcheck-0.1.0.tm => punkcheck-999999.0a1.0.tm} (99%) create mode 100644 src/modules/punkcheck-buildversion.txt rename src/modules/{shellrun-0.1.1.tm => shellrun-999999.0a1.0.tm} (99%) create mode 100644 src/modules/shellrun-buildversion.txt diff --git a/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm b/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm index caf4c107..5d8b361f 100644 --- a/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm +++ b/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm @@ -1,6 +1,5 @@ # ZIP file constructor -package provide zipper 999999.0a1.0 namespace eval zipper { namespace export initialize addentry adddir finalize @@ -193,3 +192,5 @@ if {[info exists argv0] && [string match zipper-* [file tail $argv0]]} { file delete try.zip } + +package provide zipper 999999.0a1.0 diff --git a/src/modules/commandstack-999999.0a1.0.tm b/src/modules/commandstack-999999.0a1.0.tm new file mode 100644 index 00000000..95b07c95 --- /dev/null +++ b/src/modules/commandstack-999999.0a1.0.tm @@ -0,0 +1,525 @@ + + +#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 ' for delegating to command as it was prior to rename +#changes: +#2024 +# - mungecommand to support namespaced commands +# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ +#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 { } + 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. + # 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 ? command procargs procbody" + } + lassign $arglist command procargs procbody + + set command [uplevel 1 [list namespace which $command]] + if {$command eq ""} { + #review + puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'. command '$command' not found in calling context. Ensure command name is fully qualified or that command exists." + #add something to stack? + return [dict create implementation ""] + } + 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 :: 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_ + #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 "commandstack::rename_command no rename performed for command '$command' by '$renamer'" + #add something to stack? + 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% ) + set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. + set COMMANDSTACKNEXT [%next_getter%] + ## + }] + 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 { }" + } + 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 "##" + 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 999999.0a1.0 +}] + + diff --git a/src/modules/commandstack-buildversion.txt b/src/modules/commandstack-buildversion.txt new file mode 100644 index 00000000..635e16ae --- /dev/null +++ b/src/modules/commandstack-buildversion.txt @@ -0,0 +1,3 @@ +0.4.1 +#First line must be a tm version number +#all other lines are ignored. \ No newline at end of file diff --git a/src/modules/funcl-0.1.tm b/src/modules/funcl-0.1.tm index e8430fb0..f36a1f64 100644 --- a/src/modules/funcl-0.1.tm +++ b/src/modules/funcl-0.1.tm @@ -1,3 +1,6 @@ + +#experimental. + package provide funcl [namespace eval funcl { variable version set version 0.1 @@ -210,7 +213,7 @@ namespace eval funcl { } append body [join [lreverse $tails] " "] #puts stdout "tails: $tails" - + return $body } @@ -225,7 +228,7 @@ namespace eval funcl { # _fn 0 indicates next item is an unwrapped commandlist (terminal command) # #o_of is equivalent to o_of_n 1 (1 argument o combinator) - #last n args are passed to the prior function + #last n args are passed to the prior function #e.g for n=1 f a b = f(a(b)) #e.g for n=2, e f a b = e(f(a b)) proc o_of_n {n args} { @@ -235,7 +238,7 @@ namespace eval funcl { } set comp [list] ;#composition list set end [lindex $args end] - if {[lindex $end 0] in {_fn _call}]} { + if {[lindex $end 0] in {_fn _call}} { #is_funcl set endfunc [lindex $args end] } else { @@ -246,7 +249,7 @@ namespace eval funcl { set endfunc [list _call 1 3 [list {*}$end]] } } - + if {[llength $args] == 1} { return $endfunc } diff --git a/src/modules/natsort-0.1.1.6.tm b/src/modules/natsort-999999.0a1.0.tm similarity index 94% rename from src/modules/natsort-0.1.1.6.tm rename to src/modules/natsort-999999.0a1.0.tm index d16fa718..fc5a0aa0 100644 --- a/src/modules/natsort-0.1.1.6.tm +++ b/src/modules/natsort-999999.0a1.0.tm @@ -51,7 +51,7 @@ namespace eval natsort { puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be: 'exit '" } flush stderr - } + } return -code error $msg } else { if {$type ne "exit"} { @@ -69,9 +69,6 @@ namespace eval natsort { - - - variable debug 0 variable testlist set testlist { @@ -103,18 +100,18 @@ namespace eval natsort { " 005.etc.10.txt" 005.etc.001.txt 20.somewhere.txt - 4611686018427387904999999999-bignum.txt + 4611686018427387904999999999-bignum.txt 4611686018427387903-bigishnum.txt 9223372036854775807-bigint.txt etca-a etc-a etc2-a - a0001blah.txt + a0001blah.txt a010.txt winlike-sort-difference-0.1.txt winlike-sort-difference-0.1.1.txt a1.txt - b1-a0001blah.txt + b1-a0001blah.txt b1-a010.txt b1-a1.txt -a1.txt @@ -159,7 +156,7 @@ namespace eval natsort { "Folder (01)/file.tar.gz" "Folder1/file.tar.gz" "Folder(1)/file.tar.gz" - + } lappend testlist "Some file.txt" lappend testlist " Some extra file1.txt" @@ -209,8 +206,8 @@ namespace eval natsort { } } proc left {args} { - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext + # @c overtype starting at left (overstrike) + # @c can/should we use something like this?: 'format "%-*s" $len $overtext if {[llength $args] < 2} { error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} @@ -222,7 +219,6 @@ namespace eval natsort { set opt(-overflow) 0 array set opt [lrange $args 0 end-2] - set len [string length $undertext] set overlen [string length $overtext] set diff [expr {$overlen - $len}] @@ -243,7 +239,6 @@ namespace eval natsort { return "$overtext[string range $undertext $overlen end]" } } - } #considered using hex to make large numbers more compact for viewing in debug output - but it's not that much shorter and probably obscures more than it helps. @@ -282,7 +277,7 @@ namespace eval natsort { set segments [list] while {[string length $name]} { if {[scan $name {%[0-9]%n} chunk len] == 2} { - lappend segments $chunk + lappend segments $chunk set name [string range $name $len end] } if {[scan $name {%[^0-9]%n} chunk len] == 2} { @@ -295,7 +290,7 @@ namespace eval natsort { proc padleft {str count {ch " "}} { set val [string repeat $ch $count] - append val $str + append val $str set diff [expr {max(0,$count - [string length $str])}] set offset [expr {max(0,$count - $diff)}] set val [string range $val $offset end] @@ -310,7 +305,6 @@ namespace eval natsort { proc sort_sqlite {stringlist args} { package require sqlite3 - set args [check_flags -caller natsort_sqlite -defaults [list -db :memory: -collate nocase -winlike 0 -topchars "\uFFFF" -debug 0 -splitchars [list / . - _] -extras {all}] -values $args] set db [string trim [dict get $args -db]] set collate [string trim [dict get $args -collate]] @@ -319,8 +313,7 @@ namespace eval natsort { set topdot [expr {"." in $topchars}] set topunderscore [expr {"_" in $topchars}] - - + sqlite3 db_sort_basic $db set orderedlist [list] db_sort_basic eval [string map [list %collate% $collate] {create table sqlitesort(index0 text COLLATE %collate%, name text COLLATE %collate%)}] @@ -351,7 +344,7 @@ namespace eval natsort { incr s } puts stdout ">>$index" - db_sort_basic eval {insert into sqlitesort values($index,$nm)} + db_sort_basic eval {insert into sqlitesort values($index,$nm)} } db_sort_basic eval [string map [list %collate% $collate] {select name from sqlitesort order by index0 COLLATE %collate% ASC, name COLLATE %collate% ASC }] { lappend orderedlist $name @@ -402,7 +395,7 @@ namespace eval natsort { #faster than lsearch on split for str of a few K expr {[tcl::string::length $str]-[tcl::string::length [tcl::string::map "$char {}" $str]]} } - + proc build_key {chunk splitchars topdict tagconfig debug} { variable stacktrace_on if {$stacktrace_on} { @@ -415,7 +408,6 @@ namespace eval natsort { #a book.txt #ab.txt #abacus.txt - set original_splitchars [dict get $tagconfig original_splitchars] @@ -426,7 +418,7 @@ namespace eval natsort { set tag_dashes 1 } if {("-" ni $original_splitchars)} { - set tag_dashes 1 + set tag_dashes 1 } if {$debug >= 3} { puts stdout "START build_key chunk : $chunk" @@ -441,24 +433,23 @@ namespace eval natsort { # } #} - #if {![string length $chunk]} return - + #if {![string length $chunk]} return + set result "" if {![llength $splitchars]} { - #no more structural splits - but we need to examine numeric/non-numeric segments at the lowest level. - # we are at a leaf in the recursive split hierarchy + #no more structural splits - but we need to examine numeric/non-numeric segments at the lowest level. + # we are at a leaf in the recursive split hierarchy set s "" ;#we never actually split on "" (unless that was put in splitchars.. but it probably shouldn't be) set parts [list $chunk] ;#important to treat as list or leading/trailing whitespace lost - } else { set s [lindex $splitchars 0] if {"spudbucket$s" in "[split $chunk {}]"} { error "dead-branch spudbucket" - set partindex [build_key $chunk [lrange $splitchars 1 end] $topdict $tagconfig $debug] + set partindex [build_key $chunk [lrange $splitchars 1 end] $topdict $tagconfig $debug] if {[dict get $tagconfig showsplits]} { - set pfx "(1${s}=)" ;# = sorts before _ + set pfx "(1${s}=)" ;# = sorts before _ set partindex ${pfx}$partindex } @@ -467,7 +458,7 @@ namespace eval natsort { set parts_below_index "" if {$s ni [split $chunk ""]} { - #$s can be an empty string + #$s can be an empty string set parts [list $chunk] } else { set parts [split $chunk $s] ;#whitespace preserved - even if splitting on s that is not in string. @@ -475,20 +466,20 @@ namespace eval natsort { #assert - we have a splitchar $s that is in the chunk - so at least one part if {(![string length $s] || [llength $parts] == 0)} { error "buld_key assertion false empty split char and/or no parts" - } + } set pnum 1 ;# 1 based for clarity of reading index in debug output - set subpart_count [llength $parts] + set subpart_count [llength $parts] set sub_splits [lrange $splitchars 1 end] ;#pass same splitchars to each subpart foreach p $parts { - set partindex [build_key $p $sub_splits $topdict $tagconfig $debug] + set partindex [build_key $p $sub_splits $topdict $tagconfig $debug] set lastpart [expr {$pnum == $subpart_count}] ####################### set showsplits [dict get $tagconfig showsplits] - #split prefixing experiment - maybe not suitable for general use - as it affects sort order + #split prefixing experiment - maybe not suitable for general use - as it affects sort order #note that pfx must be consistent until last one, no matter how many partnumbers there are in total. # we don't want to influence sort order before reaching end. #e.g for: @@ -504,7 +495,7 @@ namespace eval natsort { set pfx "(${pnum}${s}_" } append parts_below_index $pfx - } + } ####################### if {$lastpart} { @@ -525,10 +516,10 @@ namespace eval natsort { # module-0.1.1.2.tm if {[string length $last_part_text_tag]} { - #replace only the first text-tag (<30>) from the subpart_index + #replace only the first text-tag (<30>) from the subpart_index if {[string match "<30?>*" $partindex]} { #give textual string index a specific tag for last part in split only. e.g <130> for lower than integers - set partindex "<130>[string range $partindex 5 end]" + set partindex "<130>[string range $partindex 5 end]" } #append parts_below_index $last_part_tag } @@ -537,7 +528,6 @@ namespace eval natsort { } append parts_below_index $partindex - if {$showsplits} { @@ -547,8 +537,7 @@ namespace eval natsort { set suffix "${pnum}${s}_)" } append parts_below_index $suffix - } - + } incr pnum } @@ -566,25 +555,18 @@ namespace eval natsort { } } - #puts stdout ">>>chunk:'$chunk'<<< split-on:$s parts: '$parts' splitchars: $splitchars -topdict:$topdict" - - - - #if {$chunk eq ""} { # puts "___________________________________________!!!____" #} #puts stdout "-->chunk:$chunk $s parts:$parts" #puts stdout "---chunk:'$chunk' part:'$part' parts:'$parts' s:'$s'" - - - set segments [split_numeric_segments $chunk] ;#! + set segments [split_numeric_segments $chunk] ;#! set stringindex "" set segnum 0 foreach seg $segments { @@ -592,34 +574,31 @@ namespace eval natsort { #-strict ? if {[string length $seg] && [string is digit $seg]} { set basenum [trimzero [string trim $seg]] - set lengthindex "[padleft [string length $basenum] 4]d" + set lengthindex "[padleft [string length $basenum] 4]d" #append stringindex "<20>$lengthindex $basenum $seg" } else { set c1 [string range $seg 0 0] #puts stdout "==============> c1'$c1' topdict: $topdict stringindex:$stringindex" - + if {$c1 in [dict keys $topdict]} { set tag [dict get $topdict $c1] #append stringindex "${tag}$c1" #set seg [string range $seg 1 end] - } - #textindex + } + #textindex set leader "<30>" - set idx $seg + set idx $seg set idx [string trim $idx] set idx [string tolower $idx] set idx [string map $index_map $idx] - - - - #set the X-c count to match the length of the index - not the raw data + #set the X-c count to match the length of the index - not the raw data set lengthindex "[padleft [string length $idx] 4]c" - + #append stringindex "${leader}$idx $lengthindex $texttail" } - } + } if {[llength $parts] != 1} { error "build_key assertion fail llength parts != 1 parts:$parts" @@ -640,7 +619,7 @@ namespace eval natsort { ##don't trim spaces here - it would be inconsistent. Some subs are pure whitespace - others have internal whitespace. e.g "a4 400b a b2" becomes "a 4 { } 400 {b a b} 2" #mapping away all whitespace would be consistent, but not necessarily desirable. If it's in the index_map it'll happen anyway - so we don't do it manually here except for evaluating conditions. set test_trim [string trim $sub] - set str $sub + set str $sub set str [string tolower $str] set str [string map $index_map $str] if {[string length $test_trim] && [string is digit $test_trim]} { @@ -648,22 +627,21 @@ namespace eval natsort { } else { append partsorter "$str" } - append partsorter + append partsorter } - foreach sub $subsegments { + foreach sub $subsegments { if {[string length $sub] && [string is digit $sub]} { set basenum [trimzero [string trim $sub]] set subequivs $basenum set lengthindex "[padleft [string length $subequivs] 4]d " - set idx "$lengthindex [padleft $basenum 10]" ;#todo - cycle through data and determine longest + set idx "$lengthindex [padleft $basenum 10]" ;#todo - cycle through data and determine longest set tail [overtype::left [string repeat " " 10] $sub] #set tail "" } else { set idx "" - set lookahead [lindex $subsegments $i+1] if {![string length $lookahead]} { @@ -680,12 +658,11 @@ namespace eval natsort { append idx $zeronum set idx $subequivs - # - + set ch "-" - if {$tag_dashes} { + if {$tag_dashes} { #puts stdout "____TAG DASHES" #winlike set numleading [get_leading_char_count $seg $ch] @@ -704,12 +681,9 @@ namespace eval natsort { append textail "<30>" } } else { - set texttail "<30>" + set texttail "<30>" } - - - #set idx $partsorter set tail "" #set tail [string tolower $sub] ;#raw @@ -721,12 +695,8 @@ namespace eval natsort { incr i } - - - - if {$p eq ""} { - # no subsegments.. + # no subsegments.. set zeronum "[padleft 0 4]d0" #append grouping "\u000$zerotail" append grouping ".$zeronum" @@ -742,12 +712,10 @@ namespace eval natsort { set grouping [string trimright $grouping $s] append grouping "[padleft [llength $parts] 4]" append segtail $grouping - #append segtail " <[padleft [llength $parts] 4]>" - - append segtail "\]" + append segtail "\]" #if {[string length $seg] && [string is digit $seg]} { # append segtail "<20>" @@ -757,14 +725,11 @@ namespace eval natsort { append stringindex $segtail incr segnum - - - - + lappend indices $stringindex if {[llength $indices] > 1} { - puts stderr "INDICES [llength $indices]: $stringindex" + puts stderr "INDICES [llength $indices]: $stringindex" error "build_key assertion error deadconcept indices" } @@ -774,10 +739,10 @@ namespace eval natsort { set tag [dict get $topdict $s] set joiner [string map [list ">" "$s>"] ${tag}] #we have split on this character $s so if the first part is empty string then $s was a leading character - # we need to bring a tag out front for this, or it will be dominated by the leading sections-remaing tag + # we need to bring a tag out front for this, or it will be dominated by the leading sections-remaing tag # (since the empty string produces no tag of it's own - ?) if {[string length [lindex $parts 0]] == 0} { - set prefix ${joiner} + set prefix ${joiner} } else { set prefix "" } @@ -813,7 +778,7 @@ namespace eval natsort { #---------------------------------------- #line-processors - data always last argument - opts can be empty string - #all processor should accept empty opts and ignore opts if they don't use them + #all processor should accept empty opts and ignore opts if they don't use them proc _lineinput_as_tcl1 {opts line} { set out "" foreach i $line { @@ -857,7 +822,7 @@ namespace eval natsort { return [csv::split $line {*}$opts] } } - #opts same as tcllib csv::join + #opts same as tcllib csv::join #?sepChar? ?delChar? ?delMode? proc _lineoutput_as_csv {opts line} { package require csv @@ -902,7 +867,7 @@ namespace eval natsort { return $stringlist } } - + #allow pass through of the check_flags flag -debugargs so it can be set by the caller set debugargs 0 if {[set posn [lsearch $args -debugargs]] >=0} { @@ -917,7 +882,7 @@ namespace eval natsort { #-return flagged|defaults doesn't work Review. #flagfilter global processor/allocator not working 2023-08 - set opts [check_flags {*}$sort_flagspecs -debugargs $debugargs -values $args] + set opts [check_flags {*}$sort_flagspecs -debugargs $debugargs -values $args] #we can only shortcircuit input list of single element at this point if there aren't non-default -inputformat or -outputformat transformations if {[llength $stringlist] == 1} { @@ -951,13 +916,13 @@ namespace eval natsort { if {$debug} { #dict unset opts -showsplits - #dict unset opts -splits + #dict unset opts -splits puts stdout "natsort::sort processed_args: $opts" if {$debug == 1} { puts stdout "natsort::sort - try also -debug 2, -debug 3" } } - + #set sortmethod "-dictionary" ;# sorts a2b before a001b - possibly other strangenesses that are hard to reason about switch -- $sortmethod { dictionary - ascii { @@ -999,23 +964,23 @@ namespace eval natsort { #set commonsplits [list] set tagconfig [dict create] - dict set tagconfig last_part_text_tag "<19>" + dict set tagconfig last_part_text_tag "<19>" if {$winlike} { - set splitchars $winsplits + set splitchars $winsplits #windows explorer sorts leading spaces at the top - which doesn't seem very helpful for keeping things together - but the explorer doesn't seem able to create leading spaces anyway. - set wintop [list "(" ")" { } {.} {_}] ;#windows specific order + set wintop [list "(" ")" { } {.} {_}] ;#windows specific order foreach t $topchars { if {$t ni $wintop} { lappend wintop $t } } - set topchars $wintop + set topchars $wintop dict set tagconfig last_part_text_tag "" } else { set splitchars $commonsplits } if {$splits ne "\uFFFF"} { - set splitchars $splits + set splitchars $splits } dict set tagconfig original_splitchars $splitchars dict set tagconfig showsplits $showsplits @@ -1023,11 +988,11 @@ namespace eval natsort { #create topdict set i 0 set topdict [dict create] - foreach c $topchars { + foreach c $topchars { incr i ;#start at 01 so that 00 reserved for final-split tag (allows x-0.1.txt to sort above x-0.1.1.txt by default. Use tagconfig to change, or choose -winlike 1 for explorer-like sorting) dict set topdict $c "<0$i>" } - set keylist [list] + set keylist [list] switch -- $opt_inputformat { tcl { @@ -1037,12 +1002,12 @@ namespace eval natsort { set lineinput_transform [list _lineinput_as_csv $opt_inputformatoptions] } raw { - set lineinput_transform [list _lineinput_as_raw $opt_inputformatoptions] + set lineinput_transform [list _lineinput_as_raw $opt_inputformatoptions] } words { - set lineinput_transform [list _lineinput_as_words $opt_inputformatoptions] + set lineinput_transform [list _lineinput_as_words $opt_inputformatoptions] } - } + } switch -- $opt_outputformat { tcl { set lineoutput_transform [list _lineoutput_as_tcl $opt_outputformatoptions] @@ -1051,13 +1016,13 @@ namespace eval natsort { set lineoutput_transform [list _lineoutput_as_csv $opt_outputformatoptions] } raw { - set lineoutput_transform [list _lineoutput_as_raw $opt_outputformatoptions] + set lineoutput_transform [list _lineoutput_as_raw $opt_outputformatoptions] } words { - set lineoutput_transform [list _lineoutput_as_words $opt_outputformatoptions] + set lineoutput_transform [list _lineoutput_as_words $opt_outputformatoptions] } } - + if {("data" in $opt_inputformatapply) || ("index" in $opt_inputformatapply)} { if {$opt_inputformat eq "raw"} { set tf_stringlist $stringlist @@ -1102,7 +1067,7 @@ namespace eval natsort { } } #puts stdout "colkeys: $colkeys" - + if {$opt_inputformat eq "raw"} { #no inputformat was applied - can just use stringlist foreach value $stringlist ck $colkeys { @@ -1114,7 +1079,7 @@ namespace eval natsort { foreach keyinput $tf_index_stringlist datavalue $tf_data_stringlist ck $colkeys { #data may or may not have been transformed #column index may or may not have been built with transformed data - + set contentindex [build_key $keyinput $splitchars $topdict $tagconfig $debug] set colindex [build_key $ck $splitchars $topdict $tagconfig $debug] lappend keylist ${colindex}-${contentindex}-$datavalue ;#note: entire value used for final sort disambiguation (can be whitespace that was ignored in indexing) @@ -1146,18 +1111,16 @@ namespace eval natsort { } } ################################################################################################### - - if {$debug >= 2} { set screen_width 250 set max_val 0 set max_idx 0 ##### calculate colum widths foreach i [{*}$sortcommand] { - set len_val [string length [lindex $stringlist $i]] + set len_val [string length [lindex $stringlist $i]] if {$len_val > $max_val} { set max_val $len_val } @@ -1174,7 +1137,7 @@ namespace eval natsort { set str [overtype::left $leftcol RAW] puts stdout " $str Index with possibly transformed data at tail" foreach i [{*}$sortcommand] { - #puts stdout "|d> [overtype::left $leftcol [lindex $stringlist $i] ] [lindex $keylist $i]" + #puts stdout "|d> [overtype::left $leftcol [lindex $stringlist $i] ] [lindex $keylist $i]" set index [lindex $keylist $i] set len_idx [string length $index] set rowcount [expr {$len_idx / $r_width}] @@ -1190,18 +1153,18 @@ namespace eval natsort { set r 0 foreach idxpart $rows { if {$r == 0} { - #use the untransformed stringlist + #use the untransformed stringlist set str [overtype::left $leftcol [lindex $stringlist $i]] } else { set str [overtype::left $leftcol ...]] } - puts stdout " $str $idxpart" + puts stdout " $str $idxpart" incr r } #puts stdout "|> '[lindex $stringlist $i]'" #puts stdout "|> [lindex $keylist $i]" } - + puts stdout "|debug> topdict: $topdict" puts stdout "|debug> splitchars: $splitchars" } @@ -1229,26 +1192,25 @@ namespace eval natsort { set topchars [string trim [dict get $args -topchars]] - + set topdot [expr {"." in $topchars}] set topunderscore [expr {"_" in $topchars}] - - + sqlite3 db_natsort2 $db #-- #our table must handle the name with the greatest number of numeric/non-numeric splits. #This means a single list member with pathological naming e.g a1a1a1a1a1a1a1a1a1a1a1.txt could greatly extend the number of columns and indices and affect performance. #review: could be optimised to aggregate the tail into a single index, as the the extra columns won't assist in ordering, but make the table and query bigger. # we should probably determine the longest common sequence of splits in the input list and add only one more index for the segment after that. - set maxsegments 0 + set maxsegments 0 #-- set prefix "idx" - + #note - there will be more columns in the sorting table than segments. # (a segment equals one of the numeric & non-numeric string portions returned from 'split_numeric_sgements') #--------------------------- - # consider - # a123b.v1.2.txt + # consider + # a123b.v1.2.txt # a123b.v1.3beta1.txt # these have the following segments: # a 123 b.v 1 . 2 .txt @@ -1259,9 +1221,9 @@ namespace eval natsort { # # for example when the data has any elements in a segment position that are numeric (e.g 0001 123) # - then an index column with numeric equivalents will be created (e.g 0001 becomes 1), and any non-numeric values in that column will get mapped to a negative value (for special cases) or a high value such as NULL (with NULLS LAST sql support) - # - # when a segment - + # + # when a segment + #cycle through all strings - we cannot build tabledef as we go because the column type depends on whether all segments for a particular column are text vs int-equivalent. array set segmentinfo {} foreach nm $stringlist { @@ -1272,8 +1234,7 @@ namespace eval natsort { set segments [lrange $segments 1 end] } } - - + set c 0 ;#start of index columns if {[llength $segments] > $maxsegments} { set maxsegments [llength $segments] @@ -1291,7 +1252,7 @@ namespace eval natsort { set segmentinfo($c,type) "int" } } else { - #text never overrides int + #text never overrides int if {!$column_exists} { set segmentinfo($c,name) ${prefix}$c set segmentinfo($c,type) "text" @@ -1327,13 +1288,12 @@ namespace eval natsort { } } append tabledef "name text" - + #puts stdout "tabledef:$tabledef" db_natsort2 eval [string map [list %tabledef% $tabledef] {create table natsort(%tabledef%)}] - - + foreach nm $stringlist { array unset intdata array set intdata {} @@ -1347,7 +1307,7 @@ namespace eval natsort { } append sql_insert "\$nm" ;#don't manipulate name value in any way - e.g must leave all whitespace as the sort must return exactly the same elements as in the original list. append sql_insert ")" - + set segments [split_numeric_segments $nm] if {![string length [string trim [lindex $segments 0]]]} { if {[string is digit [string trim [lindex $segments 1]]]} { @@ -1372,7 +1332,7 @@ namespace eval natsort { } set rawdata($c) [string trim $seg] } else { - #pure text column + #pure text column #set intdata($c) [string trim $seg] ;#ignore leading/trailing whitespace - we sort first on trimmed version, then refine with the sort on rawdata index #catch {unset indata($c)} set indata($c) [string trim $seg] @@ -1386,14 +1346,14 @@ namespace eval natsort { } set orderedlist [list] - - if {$debug} { + + if {$debug} { db_natsort2 eval {select * from pragma_table_info('natsort')} rowdata { parray rowdata } } set orderby "order by " - + foreach cname $ordered_column_names { if {[string match "idx*" $cname]} { append orderby "$cname ASC NULLS LAST," @@ -1403,7 +1363,7 @@ namespace eval natsort { } append orderby " name ASC" #append orderby " NULLS LAST" ;#?? - + #e.g "order by idx0 ASC, raw0 ASC, idx1 ASC .... name ASC" if {$debug} { puts stdout "orderby clause: $orderby" @@ -1424,14 +1384,14 @@ namespace eval natsort { #puts stdout "$rowdata(name)" lappend orderedlist $rowdata(name) } - + db_natsort2 close return $orderedlist } } -#application section e.g this file might be linked from /usr/local/bin/natsort +#application section e.g this file might be linked from /usr/local/bin/natsort namespace eval natsort { namespace import ::flagfilter::check_flags @@ -1440,9 +1400,9 @@ namespace eval natsort { if {[info script] eq ""} { return 0 } - #see https://wiki.tcl-lang.org/page/main+script + #see https://wiki.tcl-lang.org/page/main+script #trailing ... let's us resolve symlinks in last component of the path (could be something else like ___ but ... seems unlikely to collide with anything in the filesystem) - if {[info exists argv0] + if {[info exists argv0] && [file dirname [file normalize [file join [info script] ...]]] eq @@ -1479,29 +1439,26 @@ namespace eval natsort { set is_namematch [called_directly_namematch] set is_inodematch [called_directly_inodematch] #### - #review - reliability of mechanisms to determine direct calls - # we don't want application being called when being used as a library, but we need it to run if called directly or from symlinks etc + #review - reliability of mechanisms to determine direct calls + # we don't want application being called when being used as a library, but we need it to run if called directly or from symlinks etc #-- choose a policy and leave the others commented. - #set is_called_directly $is_namematch - #set is_called_directly $is_inodematch + #set is_called_directly $is_namematch + #set is_called_directly $is_inodematch #puts "NATSORT: called_directly_namematch - $is_namematch" #puts "NATSORT: called_directly_inodematch - $is_inodematch" #flush stdout - set is_called_directly [expr {$is_namematch || $is_inodematch}] - #set is_called_directly [expr {$is_namematch && $is_inodematch}] + set is_called_directly [expr {$is_namematch || $is_inodematch}] + #set is_called_directly [expr {$is_namematch && $is_inodematch}] ### - - + #puts stdout "called_directly_name: [called_directly_namematch] called_directly_inode: [called_directly_inodematch]" } else { #safe interp set is_called_directly 0 } - - proc test_pass_fail_message {pass {additional ""}} { variable test_fail_msg variable test_pass_msg @@ -1549,10 +1506,10 @@ namespace eval natsort { set sorted [natsort::sort $input {*}$args] set is_match [struct::list equal $input $sorted] - + set msg "windows-explorer order" - test_pass_fail_message $is_match $msg + test_pass_fail_message $is_match $msg puts stdout [string repeat - 40] puts stdout INPUT puts stdout [string repeat - 40] @@ -1607,7 +1564,7 @@ namespace eval natsort { foreach item $sorted { puts stdout $item } - + test_pass_fail_message $is_match $msg } @@ -1636,7 +1593,7 @@ namespace eval natsort { set posn [lsearch $args -debug] if {$posn > 0} { if {[lindex $args $posn+1]} { - set debug [lindex $args $posn+1] + set debug [lindex $args $posn+1] } } if {$debug} { @@ -1665,7 +1622,7 @@ namespace eval natsort { } lappend targets $targetitem if {$debug} { - puts stderr "|debug>commandline_ls listing for $targetitem" + puts stderr "|debug>commandline_ls listing for $targetitem" } } } @@ -1716,35 +1673,35 @@ namespace eval natsort { set sorted_folders [natsort::sort $allfolders {*}$args] set sorted_files [natsort::sort $allfiles {*}$args] - + foreach fold $sorted_folders { puts stdout $fold } foreach file $sorted_files { puts stdout $file } - + return "-- ok printed to stdout [llength $sorted_folders] folders and [llength $sorted_files] files --" } - package require argp - argp::registerArgs commandline_test { - { -showsplits boolean 0} - { -stacktrace boolean 0} - { -debug boolean 0} - { -winlike boolean 0} - { -db string ":memory:"} - { -collate string "nocase"} - { -algorithm string "sort"} - { -topchars string "\uFFFF"} - { -testlist string {10 1 30 3}} - } - argp::setArgsNeeded commandline_test {-stacktrace} + #package require argp + #argp::registerArgs commandline_test { + # { -showsplits boolean 0} + # { -stacktrace boolean 0} + # { -debug boolean 0} + # { -winlike boolean 0} + # { -db string ":memory:"} + # { -collate string "nocase"} + # { -algorithm string "sort"} + # { -topchars string "\uFFFF"} + # { -testlist string {10 1 30 3}} + #} + #argp::setArgsNeeded commandline_test {-stacktrace} proc commandline_test {test args} { variable testlist puts stdout "commandline_test got $args" - argp::parseArgs opts - puts stdout "commandline_test got [array get opts]" + #argp::parseArgs opts + #puts stdout "commandline_test got [array get opts]" set args [check_flags -caller natsort_commandline {*}{ } -return flagged|defaults {*}{ } -defaults [list -db :memory: -collate nocase -testlist $testlist -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] {*}{ @@ -1764,7 +1721,7 @@ namespace eval natsort { # dict unset args -stacktrace set argtestlist [dict get $args -testlist] - dict unset args -testlist + dict unset args -testlist set debug [dict get $args -debug] @@ -1806,9 +1763,8 @@ namespace eval natsort { if {$runtests eq "1"} { set runtests "*" } - - set testcommands [info commands ${test_prefix}${runtests}] + set testcommands [info commands ${test_prefix}${runtests}] if {![llength $testcommands]} { puts stderr "No test commands matched -runtests argument '$runtests'" puts stderr "Use 1 to run all tests" @@ -1851,7 +1807,7 @@ namespace eval natsort { puts stderr "|debug> natsort_pipe got args:'$args'" } set algorithm [dict get $args -algorithm] - dict unset args -algorithm + dict unset args -algorithm set proclist [info commands ::natsort::sort*] set algos [list] @@ -1939,7 +1895,7 @@ namespace eval natsort { set cmdprocessors { {testcmd {match "^test$" dispatch natsort::commandline_test singleopts {-l}}} {testcmd {sub testname default "1" singleopts {-l}}} - } + } set arglist [check_flags {*}{ -debugargs 0 -caller cline_dispatch2 @@ -1947,7 +1903,7 @@ namespace eval natsort { -soloflags {-v -l} } -defaults [list -collate nocase -algorithm sort -testlist "1 2 3 10" -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] {*}{ -required {all} - -extras {all} + -extras {all} } -commandprocessors $cmdprocessors {*}{ } -values $::argv {*}{ } @@ -1968,7 +1924,7 @@ namespace eval natsort { exit 0 if {$::argc} { - + } } } @@ -1976,7 +1932,7 @@ namespace eval natsort { package provide natsort [namespace eval natsort { variable version - set version 0.1.1.6 + set version 999999.0a1.0 }] diff --git a/src/modules/natsort-buildversion.txt b/src/modules/natsort-buildversion.txt new file mode 100644 index 00000000..f747d593 --- /dev/null +++ b/src/modules/natsort-buildversion.txt @@ -0,0 +1,3 @@ +0.1.1.7 +#First line must be a tm version number +#all other lines are ignored. \ No newline at end of file diff --git a/src/modules/oolib-0.1.2.tm b/src/modules/oolib-999999.0a1.0.tm similarity index 99% rename from src/modules/oolib-0.1.2.tm rename to src/modules/oolib-999999.0a1.0.tm index 858c61cd..fb68d7cb 100644 --- a/src/modules/oolib-0.1.2.tm +++ b/src/modules/oolib-999999.0a1.0.tm @@ -1,9 +1,5 @@ #JMN - api should be kept in sync with package patternlib where possible # -package provide oolib [namespace eval oolib { - variable version - set version 0.1.2 -}] namespace eval oolib { oo::class create collection { @@ -121,7 +117,7 @@ namespace eval oolib { # if {$v eq $key} { # lappend result $n $v # } - # } + # } # return $result # } else { # return [array get o_alias] @@ -196,6 +192,9 @@ namespace eval oolib { return $seed } } - } +package provide oolib [namespace eval oolib { + variable version + set version 999999.0a1.0 +}] diff --git a/src/modules/oolib-buildversion.txt b/src/modules/oolib-buildversion.txt new file mode 100644 index 00000000..1f3befba --- /dev/null +++ b/src/modules/oolib-buildversion.txt @@ -0,0 +1,3 @@ +0.1.3 +#First line must be a tm version number +#all other lines are ignored. \ No newline at end of file diff --git a/src/modules/overtype-999999.0a1.0.tm b/src/modules/overtype-999999.0a1.0.tm index a298da2b..eec7d4e8 100644 --- a/src/modules/overtype-999999.0a1.0.tm +++ b/src/modules/overtype-999999.0a1.0.tm @@ -263,6 +263,7 @@ tcl::namespace::eval overtype { -wrap -default 0 -type boolean -info -default 0 -type boolean -help\ "When set to 1, return a dictionary (experimental)" + -format -default ansi -type string -choices {ansi binarytext-bios binarytext-ice xbin} -binarytext -default "" -type string -choices {"" bios ice} -console -default {stdin stdout stderr} -type list @@ -337,6 +338,7 @@ tcl::namespace::eval overtype { -wrap 0 -info 0 -binarytext "" + -format ansi -console {stdin stdout stderr} }] #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. @@ -357,7 +359,7 @@ tcl::namespace::eval overtype { - -expand_right - -appendlines - -reverse_mode - -crm_mode - -insert_mode - -cp437 - - -info - -binarytext - -console { + - -info - -binarytext - -format - -console { tcl::dict::set opts $k $v } -wrap - -autowrap_mode { @@ -398,22 +400,23 @@ tcl::namespace::eval overtype { set opt_cp437 [tcl::dict::get $opts -cp437] set opt_info [tcl::dict::get $opts -info] set opt_binarytext [tcl::dict::get $opts -binarytext] + set opt_format [tcl::dict::get $opts -format] set opt_console [tcl::dict::get $opts -console] #-------------------------------------------------------------------------- #TODO #REVIEW - punk::console package may not be loaded - set cursor_style_overtype {3 underline-blink} - set cursor_style_insert {5 beam-blink} - if {$opt_insert_mode} { - set initial_cursor_style $cursor_style_insert - } else { - set initial_cursor_style $cursor_style_overtype - } - catch { - punk::console::cursor_style -console $opt_console $cursor_style_overtype - } + #set cursor_style_overtype {3 underline-blink} + #set cursor_style_insert {5 beam-blink} + #if {$opt_insert_mode} { + # set initial_cursor_style $cursor_style_insert + #} else { + # set initial_cursor_style $cursor_style_overtype + #} + #catch { + # punk::console::cursor_style -console $opt_console $cursor_style_overtype + #} #-------------------------------------------------------------------------- # ---------------------------- @@ -574,8 +577,8 @@ tcl::namespace::eval overtype { } 4 { set inputchunks [list] - switch -- $opt_binarytext { - "" { + switch -- $opt_format { + ansi { foreach ln [split $overblock \n] { lappend inputchunks [list mixed $ln\n] } @@ -583,13 +586,13 @@ tcl::namespace::eval overtype { lset inputchunks end 1 [tcl::string::range [lindex $inputchunks end 1] 0 end-1] } } - bios { + binarytext-bios { #16 fg, 8 fg + possible blink set input "" set ansisplit [list ""] set charpair 0 foreach {ch at} [split $overblock ""] { - #review - does binarytext only apply to cp437??? we need to know the original encoding + #review - does binarytext only apply to cp437??? we need to know the original encoding set at [encoding convertto cp437 $at] if {[catch {punk::ansi::colour::byteAnsi $at} code]} { puts stderr "renderspace err at charpair: $charpair [punk::ansi::ansistring VIEW ${ch}${at}]" @@ -604,7 +607,7 @@ tcl::namespace::eval overtype { #lappend inputchunks [list mixed $input] lappend inputchunks [list ansisplit $ansisplit] } - ice { + binarytext-ice { #16 fg, 16 bg (no blink) set input "" foreach {ch at} [split $overblock ""] { @@ -613,6 +616,135 @@ tcl::namespace::eval overtype { } lappend inputchunks [list mixed $input] } + xbin { + set xbin_header [string range $overblock 0 10] ;#11 bytes + set xbin_header_info [punk::ansi::xbin::parse_header $xbin_header] + set overblock [string range $overblock 11 end] + + set flags [dict get $xbin_header_info flags] + + puts "xbin [dict get $xbin_header_info width]x[dict get $xbin_header_info height]" + puts "xbin flags $flags" + + #TODO - compression bios ice + #hack - skip over palette (48 bytes) + if {"palette" in $flags} { + puts stderr "renderspace warning - palette unimplemented" + set overblock [string range $overblock 48 end] + } + #hack - skip over font 256 x fontsize or 512 x fontsize + if {"512chars" in $flags} { + set sz 512 + } else { + set sz 256 + } + #temp + set skip [expr {$sz * [dict get $xbin_header_info fontsize]}] + if {"font" in $flags} { + puts stderr "renderspace warning - font unimplemented" + set overblock [string range $overblock $skip end] + } + puts stdout "xbin image data size [string length $overblock]" + + set ansisplit [list ""] + if {"compress" in $flags} { + #puts stderr "renderspace warning - compress experimental" + #process 'repeatcounter' bytes + #first 2 bits - compression type + # 00 - no compression + # 01 - character compression + # 10 - attribute compression + # 11 - character/attribute compression + #remaining 6 bits - counter + set input "" + set bytes [split $overblock ""] + #hacktest + for {set b 0} {$b < [llength $bytes]} {} { + set rc [lindex $bytes $b] + set dec [scan $rc %c] + set ctype [expr {$dec >> 6}] + #0x3F - 00111111 + set count [expr {$dec & 0x3F}] + incr count ;#count stored as 1 less than actual number of repeats + if {$count < 1 || $count > 64} { + puts stderr "xbin - something wrong - max must be between 1 and 64 inclusive. received $count" + } + if {$count == 32} { + puts stderr "xbin ---> byte:[ansistring VIEW $rc] at posn $b" + } + incr b + switch -- $ctype { + 0 { + #no compression + for {set c 0} {$c < $count*2} {incr c 2} { + set ch [lindex $bytes $b+$c] + set ch [encoding convertfrom cp437 $ch] + set at [lindex $bytes [expr {$b+$c+1}]] + binary scan $at cu code + #set clr [a+ term-$code] + set clr [a+ red] + lappend ansisplit $clr $ch + } + incr b [expr {$count*2}] + } + 1 { + #char compression + set ch [lindex $bytes $b] + set ch [encoding convertfrom cp437 $ch] + incr b + for {set c 0} {$c < $count} {incr c} { + set at [lindex $bytes $b+$c] + binary scan $at cu code + #set clr [a+ term-$code] + set clr [a+ cyan] + lappend ansisplit $clr $ch + } + incr b [expr {$count}] + } + 2 { + #attribute compression + set at [lindex $bytes $b] + binary scan $at cu code + #set clr [a+ term-$code] + set clr [a+ green] + incr b + for {set c 0} {$c < $count} {incr c} { + set ch [lindex $bytes $b+$c] + set ch [encoding convertfrom cp437 $ch] + lappend ansisplit $clr $ch + } + incr b $count + } + 3 { + #attribute and char compression + set ch [lindex $bytes $b] + set ch [encoding convertfrom cp437 $ch] + set at [lindex $bytes $b+1] + binary scan $at cu code + #set clr [a+ term-$code] + set clr [a+ white] + for {set c 0} {$c < $count} {incr c} { + lappend ansisplit $clr $ch + } + incr b 2 + } + } + + } + lappend inputchunks [list ansisplit $ansisplit] + } else { + foreach {ch at} [split $overblock ""] { + binary scan $at cu code + #palette? + set clr [a+ term-$code] + set ch [encoding convertfrom cp437 $ch] + lappend ansisplit $clr $ch + } + lappend inputchunks [list ansisplit $ansisplit] + } + puts stdout "xbin decoded" + flush stdout + } } } } @@ -2303,8 +2435,10 @@ tcl::namespace::eval overtype { #At the moment we return a reset at the end of the renderline result instead of the replay codes. proc renderline {args} { - #todo - fix 'unapplied' mechanism.This is particularly inefficient for long lines, or data such as binarytext which is not line-based. - #All unapplied data is re-split/reprocessed repeatedly for each line! This is very wasteful and slow. + #------------------------------------------------------------------------------------------------------------------------------------- + #todo - fix 'unapplied' mechanism.This is particularly inefficient for long lines, or data such as binarytext/xbin which is not line-based. + #All unapplied data is re-split/reprocessed repeatedly for each line! This is very wasteful and very slow. + #------------------------------------------------------------------------------------------------------------------------------------- # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. diff --git a/src/modules/patternpunk-1.1.tm b/src/modules/patternpunk-999999.0a1.0.tm similarity index 99% rename from src/modules/patternpunk-1.1.tm rename to src/modules/patternpunk-999999.0a1.0.tm index f373a320..bcd3e5e8 100644 --- a/src/modules/patternpunk-1.1.tm +++ b/src/modules/patternpunk-999999.0a1.0.tm @@ -16,7 +16,7 @@ package require overtype package require punk::args package require punk::ansi package require punk::lib -pattern::init +#pattern::init @@ -444,7 +444,7 @@ namespace eval patternpunk::lib { package provide patternpunk [namespace eval patternpunk { variable version - set version 1.1 + set version 999999.0a1.0 }] #]]> # diff --git a/src/modules/patternpunk-buildversion.txt b/src/modules/patternpunk-buildversion.txt new file mode 100644 index 00000000..2ea066b8 --- /dev/null +++ b/src/modules/patternpunk-buildversion.txt @@ -0,0 +1,3 @@ +1.1.1 +#First line must be a semantic version number +#all other lines are ignored. \ No newline at end of file diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-999999.0a1.0.tm similarity index 99% rename from src/modules/punk-0.1.tm rename to src/modules/punk-999999.0a1.0.tm index 91ead8b0..ca6ec1f4 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-999999.0a1.0.tm @@ -4,6 +4,7 @@ namespace eval punk { proc lazyload {pkg} { + #experimental - for binary packages that have significant load time. package require zzzload if {[package provide $pkg] eq ""} { zzzload::pkg_require $pkg @@ -604,7 +605,6 @@ namespace eval punk { } package require shellfilter package require punkapp - package require funcl package require struct::list package require fileutil @@ -5082,6 +5082,8 @@ namespace eval punk { #tags ? #debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5 if {false} { + #experimental. + package require funcl #set s [list uplevel 1 [concat $rhs $segment_members_filled]] if {![info exists pscript]} { upvar ::_pipescript pscript @@ -9279,7 +9281,7 @@ punkcheck::cli set_alias punkcheck package provide punk [namespace eval punk { #FUNCTL variable version - set version 0.1 + set version 999999.0a1.0 }] diff --git a/src/modules/punk-buildversion.txt b/src/modules/punk-buildversion.txt new file mode 100644 index 00000000..48ca3d02 --- /dev/null +++ b/src/modules/punk-buildversion.txt @@ -0,0 +1,3 @@ +0.1.1 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 693d863c..0ffab391 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -128,6 +128,7 @@ tcl::namespace::eval punk::ansi::class { -height -type integer -default "" -crm_mode -type boolean -default 0 -binarytext -type string -default "" -choices {"" bios ice} + -format -type string -choices {ansi binarytext-bios binarytext-ice xbin} @values -min 0 -max 0 }] method rendertest {args} { @@ -136,6 +137,7 @@ tcl::namespace::eval punk::ansi::class { set opt_height [dict get $argd opts -height] set opt_crm_mode [dict get $argd opts -crm_mode] set opt_binarytext [dict get $argd opts -binarytext] + set opt_format [dict get $argd opts -format] set existing_dimensions $o_render_dimensions if {![regexp {^([0-9]+)[xX]([0-9]+)$} $existing_dimensions _m w h]} { @@ -151,7 +153,8 @@ tcl::namespace::eval punk::ansi::class { set o_render_dimensions ${w}x${h} - set rendered [overtype::renderspace -binarytext $opt_binarytext -cp437 1 -crm_mode $opt_crm_mode -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] + #set rendered [overtype::renderspace -binarytext $opt_binarytext -cp437 1 -crm_mode $opt_crm_mode -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] + set rendered [overtype::renderspace -format $opt_format -cp437 1 -crm_mode $opt_crm_mode -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] return $rendered } @@ -630,7 +633,8 @@ tcl::namespace::eval punk::ansi { package require punk::ansi::sauce set sdict [punk::ansi::sauce::from_file $filename] set result "" - if {[dict size $sdict]} { + #if no sauce header - sdict will contain only posn -1 + if {[dict size $sdict] > 1} { if {$opt_return eq "dict"} { return $sdict } @@ -700,28 +704,74 @@ tcl::namespace::eval punk::ansi { #if SAUCE data is present - it may give an indication of encoding as well as number of columns/lines if {![catch {package require punk::ansi::sauce}]} { if {[catch {punk::ansi::sauce::from_file $fname} sdict]} { - #no 128 Byte SAUCE record at end of file + #error parsing 128 Byte SAUCE record at end of file set sdict [dict create] } + #if no error - there may be no SAUCE record at all (sdict is just posn -1) } else { puts stderr "Warning punk::ansi::sauce package not loaded - unable to detect or use any SAUCE data to aid in display" } - if {![dict size $sdict]} { - if {[string tolower [file extension $fname]] eq ".bin"} { - #In the absence of SAUCE data - assume .bin is binary text - set binarytext bios ;#16 fg, 8 bg + blink + + set format ansi ;#default assumption + + + if {[dict size $sdict] < 2} { + #either no SAUCE (dict is just posn -1) or there was an error during sauce::from_file parsing (empty sdict) + switch -exact -- [string tolower [file extension $fname]] { + .bin { + #In the absence of SAUCE data - assume .bin is binary text + set binarytext bios ;#16 fg, 8 bg + blink + set format binarytext-bios + } + .xb { + set format xbin + } } } + + #review - we open and read from file twice - once for sauce, once to slurp in whole file. + # - consider optimising to read file in first and use slurped data for sauce + #(create punk::ansi::sauce::from_data ?) + set ansidata [fcat -translation binary $fname] + if {[dict size $sdict] && [dict get $sdict posn] != -1} { + #the SAUCE ctrl-z may not be the only ctrl-z in the file data + #use the position returned by sauce::from_file rather than splitting on ctrl-z + #posn will be -1 if no SAUCE, or the position of the ctrl-z immediatly before the entire SAUCE block (including comments) + set ansidata [string range $ansidata 0 [dict get $sdict posn]-1] + } + + if {[dict exists $sdict datatype_name]} { - if {[dict get $sdict datatype_name] eq "binarytext"} { - #todo - SAUCE ANSiFlags - ice vs default bios - if {[dict exists $sdict ansiflags_ice] && [dict get $sdict ansiflags_ice]} { - set binarytext ice - } else { - set binarytext bios + switch -- [dict get $sdict datatype_name] { + binarytext { + #SAUCE ANSiFlags - ice vs default bios + if {[dict exists $sdict ansiflags_ice] && [dict get $sdict ansiflags_ice]} { + set binarytext ice + set format binarytext-ice + } else { + set binarytext bios + set format binarytext-bios + } + } + xbin { + set format xbin + } + default { } } } + + if {$format eq "xbin"} { + set ansidata [fcat -translation binary $fname] ;#don't split on \x1a - this is also present in xbin header + set xbin_header [string range $ansidata 0 10] ;#11 bytes + set non_header [string range $ansidata 11 end] + #set ansidata $xbin_header[lindex [split $non_header \x1a] 0] ;#ignore sauce at tail + set xbin_header_info [punk::ansi::xbin::parse_header $xbin_header] + #keys width height fontsize flags + set dimensions [dict get $xbin_header_info width]x[dict get $xbin_header_info height] ;#cols x rows + } + + if {$encoding eq ""} { if {[dict exists $sdict codepage]} { set encoding [dict get $sdict codepage] @@ -733,11 +783,13 @@ tcl::namespace::eval punk::ansi { if {$dimensions eq ""} { # defaults - if {$binarytext ne ""} { + if {[string match binarytext* $format]} { set cols 160 } else { set cols 80 } + + #sauce-specified if {[dict exists $sdict columns]} { set c [dict get $sdict columns] if {$c > 0} { @@ -764,17 +816,23 @@ tcl::namespace::eval punk::ansi { } lassign [split $dimensions x] cols rows - #set ansidata [fcat -encoding $encoding $fname] - set ansidata [lindex [split [fcat -translation binary $fname] \x1a] 0] - #hack - #if {$binarytext eq ""} { + if {$format eq "xbin"} { + #review + ##don't decode binary xbin header + #set hdr [string range $ansidata 0 10] + #set data [encoding convertfrom $encoding [string range $ansidata 11 end]] + #set ansidata $hdr$data + + #don't convert at all - compressed is binary? + } else { set ansidata [encoding convertfrom $encoding $ansidata] - #} + } set obj [punk::ansi::class::class_ansi new $ansidata] if {$encoding eq "cp437"} { - set result [$obj rendertest -binarytext $binarytext -width $cols -height $rows -crm_mode $opt_crm_mode] + #set result [$obj rendertest -binarytext $binarytext -width $cols -height $rows -crm_mode $opt_crm_mode] + set result [$obj rendertest -format $format -width $cols -height $rows -crm_mode $opt_crm_mode] } else { set result [$obj render $dimensions] } @@ -7070,6 +7128,12 @@ be as if this was off - ie lone CR. set prev_stop_idx [lsearch -integer -bisect $tstops $current_column] set next_stop [lindex $tstops $prev_stop_idx+1] ;#if our current_column is exactly on a stop, we still want to move to the next stop. + if {$next_stop eq ""} { + #if we run out of stops + #Review + break + } + # how far is the next tab position ? #set dist [expr {$num - ($currPos % $num)}] set this_tab_width [expr {$next_stop - $current_column}] ;#diff between two adjacent columns is one. @@ -11847,6 +11911,53 @@ namespace eval punk::ansi::colour { dict get $byte_to_ansi_ice $char } } +tcl::namespace::eval punk::ansi::xbin { + proc parse_header {str} { + #https://web.archive.org/web/20120204063040/http://www.acid.org/info/xbin/x_spec.htm + if {[string length $str] < 11} { + error "punk::ansi::xbin::parse_header error - invalid XBIN header - less than 11 bytes received" + } + set xbin_header [string range $str 0 10] ;#11 bytes + + set xbin_id [string range $xbin_header 0 3] + if {$xbin_id ne "XBIN"} { + error "punk::ansi::xbin::parse_header error - invalid XBIN header" + } + set xbin_eofchar [string index $xbin_header 4] + set xbin_width_raw [string range $xbin_header 5 6] + binary scan $xbin_width_raw su xbin_width ;#16bit unsigned little-endian + set xbin_height_raw [string range $xbin_header 7 8] + binary scan $xbin_height_raw su xbin_height ;#16bit unsigned little-endian + + set xbin_fontsize_raw [string index $xbin_header 9] + if {[binary scan $xbin_fontsize_raw cu xbin_fontsize]} { + #1 byte - unsigned + #numeric number of pixel rows (scanlines) in font. + #Any value from 1 to 32 is technically possible on VGA. + #Any other values should be considered illegal + if {$xbin_fontsize < 1 || $xbin_fontsize > 32} { + error "punk::ansi::xbin::parse_header error - invalid XBIN header - fontsize not in range 1 to 32 inclusive. received $xbin_fontsize" + } + } + set xbin_flags_raw [string index $xbin_header 10] + #valid flags: 512chars nonblink compress font palette + #bits: + #7 unused 6 unused 5 unused 4 512chars 3 nonblink 2 compress 1 font 0 palette + binary scan $xbin_flags_raw B8 flagbits + set flagbits [lrange [split $flagbits ""] 3 end] ;#skip first 3 unused + set allflags [list 512chars nonblink compress font palette] + set xbin_flags [list] + #puts "flagbits $flagbits" + foreach b $flagbits f $allflags { + if {$b} { + lappend xbin_flags $f + } + } + #width - number of columns, height - number of character rows + return [dict create width $xbin_width height $xbin_height fontsize $xbin_fontsize flags $xbin_flags] + } + +} tcl::namespace::eval punk::ansi::internal { proc splitn {str {len 1}} { #from textutil::split::splitn diff --git a/src/modules/punk/ansi/sauce-999999.0a1.0.tm b/src/modules/punk/ansi/sauce-999999.0a1.0.tm index c6cd9d79..eb6ea865 100644 --- a/src/modules/punk/ansi/sauce-999999.0a1.0.tm +++ b/src/modules/punk/ansi/sauce-999999.0a1.0.tm @@ -39,32 +39,35 @@ tcl::namespace::eval punk::ansi::sauce { proc from_file {fname} { if {[file size $fname] < 128} { - return + return [dict create posn -1] } set fd [open $fname r] chan conf $fd -translation binary chan seek $fd -128 end + set sauce_block_posn [expr {[chan tell $fd] -1}] ;#entire sauce block including ctrl-z and any comments - initial value assuming no comments + #If we treat the ctrl-z (\x1a) as part of the sauce - actual start of entire sauce info is 1 before sauce_header_posn, + #or further back if there are comments. 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} { + set saucestart [string first SAUCE00 $srec] + if {$saucestart <= 0} { close $fd - return + return [dict create posn -1] } #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 [string range $srec $saucestart 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 + return [dict create posn -1] } dict set sdict warning "SAUCE truncation to $srec_len bytes detected" } @@ -73,6 +76,7 @@ tcl::namespace::eval punk::ansi::sauce { #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 sauce_block_posn [expr {[chan tell $fd] -1}] ;#entire sauce block including ctrl-z and any comments set tag [chan read $fd 5] if {$tag eq "COMNT"} { #'character' data - shouldn't be null terminated c-style string - but can be @@ -95,6 +99,7 @@ tcl::namespace::eval punk::ansi::sauce { dict set sdict commentlines $commentlines } } + dict set sdict posn $sauce_block_posn close $fd return $sdict } @@ -447,11 +452,13 @@ tcl::namespace::eval punk::ansi::sauce { } 6 { - #xbin - only filtype is 0 + #xbin - only filetype 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] + #Values from sauce record are probably only informational, because xbin has an 11-byte header with width,height,fontsize and flags. + #presumably the header-info should take precedence over all sauce data (? review) } } if {[dict exists $sdict fontname]} { diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index 9e0a3cb9..49921e5b 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -71,11 +71,6 @@ package require punk::args -#if {"windows" eq $::tcl_platform(platform)} { -# #package require zzzload -# #zzzload::pkg_require twapi -#} - #see https://learn.microsoft.com/en-us/windows/console/classic-vs-vt #https://learn.microsoft.com/en-us/windows/console/creating-a-pseudoconsole-session diff --git a/src/modules/punk/du-999999.0a1.0.tm b/src/modules/punk/du-999999.0a1.0.tm index 6f69c4db..8d7cef72 100644 --- a/src/modules/punk/du-999999.0a1.0.tm +++ b/src/modules/punk/du-999999.0a1.0.tm @@ -2529,21 +2529,30 @@ namespace eval punk::du { #jmn disable twapi #tailcall du_dirlisting_generic $folderpath {*}$args - package require zzzload - set loadstate [zzzload::pkg_require twapi] - - if {$loadstate ni [list loading failed]} { - #either already loaded by zzload or ordinary package require - package require twapi ;#should be fast once twapi dll loaded in zzzload thread + #package require zzzload + #set loadstate [zzzload::pkg_require twapi] + + #if {$loadstate ni [list loading failed]} { + # #either already loaded by zzload or ordinary package require + # package require twapi ;#should be fast once twapi dll loaded in zzzload thread + # set ::punk::du::has_twapi 1 + # punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi + # tailcall du_dirlisting_twapi $folderpath {*}$args + #} else { + # if {$loadstate eq "failed"} { + # puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" + # punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + # } + # tailcall du_dirlisting_generic $folderpath {*}$args + #} + if {[catch {package require twapi} errM]} { + puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed: $errM" + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + tailcall du_dirlisting_generic $folderpath {*}$args + } else { set ::punk::du::has_twapi 1 punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi tailcall du_dirlisting_twapi $folderpath {*}$args - } else { - if {$loadstate eq "failed"} { - puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" - punk::du::active::set_active_function du_dirlisting du_dirlisting_generic - } - tailcall du_dirlisting_generic $folderpath {*}$args } } default { diff --git a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm index 0c73f5eb..59d2e84a 100644 --- a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm @@ -247,12 +247,6 @@ namespace eval punk::mix::commandset::loadedlib { set opts [dict merge $defaults $args] set opt_askme [dict get $opts -askme] - if {[catch {package require natsort}]} { - set has_natsort 0 - } else { - set has_natsort 1 - } - catch {package require $library 1-0} ;#ensure pkg system has loaded/searched for everything for the path of the specified library (using unsatisfiable version range) if {[file pathtype $modulefoldername] eq "absolute"} { @@ -321,11 +315,6 @@ namespace eval punk::mix::commandset::loadedlib { set versions [package versions [lindex $libfound 0]] set versions [lsort -command {package vcompare} $versions] - #if {$has_natsort} { - # set versions [natsort::sort $versions] - #} else { - # set versions [lsort $versions] - #} if {![llength $versions]} { error "No version numbers found for library/module $libfound - sorry, you will need to copy it across manually" } diff --git a/src/modules/punk/mod-0.1.tm b/src/modules/punk/mod-999999.0a1.0.tm similarity index 99% rename from src/modules/punk/mod-0.1.tm rename to src/modules/punk/mod-999999.0a1.0.tm index 8f1ba266..9a4ca094 100644 --- a/src/modules/punk/mod-0.1.tm +++ b/src/modules/punk/mod-999999.0a1.0.tm @@ -104,7 +104,6 @@ namespace eval punk::mod::cli { } } } - return $apps } } @@ -137,8 +136,6 @@ namespace eval punk::mod::cli { error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" } } - - } namespace eval punk::mod::cli { @@ -154,7 +151,7 @@ namespace eval punk::mod::cli { package provide punk::mod [namespace eval punk::mod { variable version - set version 0.1 + set version 999999.0a1.0 }] diff --git a/src/modules/punk/mod-buildversion.txt b/src/modules/punk/mod-buildversion.txt new file mode 100644 index 00000000..c3ca4d16 --- /dev/null +++ b/src/modules/punk/mod-buildversion.txt @@ -0,0 +1,3 @@ +0.1.1 +#First line must be a semantic version number +#all other lines are ignored. \ No newline at end of file diff --git a/src/modules/punk/nav/fs-999999.0a1.0.tm b/src/modules/punk/nav/fs-999999.0a1.0.tm index b65f7277..32746eab 100644 --- a/src/modules/punk/nav/fs-999999.0a1.0.tm +++ b/src/modules/punk/nav/fs-999999.0a1.0.tm @@ -847,7 +847,7 @@ tcl::namespace::eval punk::nav::fs { Regardless of whether -nonportable is supplied or not, some characters are not suitable for windows or most other platforms and will be rejected with an error. - An example of this is the null character (\0)." + An example of this is the null character (\\0)." @values -min 1 -max -1 -type string path -type string -multiple 1 -help\ "Path(s) to create. Can be absolute or relative. diff --git a/src/modules/punk/overlay-0.1.tm b/src/modules/punk/overlay-999999.0a1.0.tm similarity index 99% rename from src/modules/punk/overlay-0.1.tm rename to src/modules/punk/overlay-999999.0a1.0.tm index 283907fb..94b225bd 100644 --- a/src/modules/punk/overlay-0.1.tm +++ b/src/modules/punk/overlay-999999.0a1.0.tm @@ -186,8 +186,7 @@ tcl::namespace::eval ::punk::overlay { } } - package provide punk::overlay [tcl::namespace::eval punk::overlay { variable version - set version 0.1 + set version 999999.0a1.0 }] diff --git a/src/modules/punk/overlay-buildversion.txt b/src/modules/punk/overlay-buildversion.txt new file mode 100644 index 00000000..c3ca4d16 --- /dev/null +++ b/src/modules/punk/overlay-buildversion.txt @@ -0,0 +1,3 @@ +0.1.1 +#First line must be a semantic version number +#all other lines are ignored. \ No newline at end of file diff --git a/src/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm index 21905f43..9a3d9612 100644 --- a/src/modules/punk/repl-999999.0a1.0.tm +++ b/src/modules/punk/repl-999999.0a1.0.tm @@ -1076,13 +1076,19 @@ namespace eval punk::repl::class { append debug \n "input:[ansistring VIEW -lf 1 -vt 1 $new0] before row:$o_cursor_row after row: $result_row before col:$o_cursor_col after col:$result_col" package require textblock set debug [textblock::frame -type $frametype -checkargs 0 -buildcache 0 $debug] - if {![punk::console::vt52]} { - catch {punk::console::move_emitblock_return $debug_first_row 1 $debug} - } else { - #?? - } + + #------------------------------------ + punk::console::cursorsave_move_emitblock_return $debug_first_row 1 $debug ;#supports also vt52 + #if {![punk::console::vt52]} { + # #review + # catch {punk::console::move_emitblock_return $debug_first_row 1 $debug} + #} else { + # #?? + #} + #------------------------------------ # -- --- --- --- --- --- + set o_cursor_col $result_col set cursor_row_idx [expr {$o_cursor_row-1}] lset o_rendered_lines $cursor_row_idx $result @@ -3533,13 +3539,13 @@ namespace eval repl { punk::ansi punk::lib overtype - dictutils debug punk::ns textblock punk::args::moduledoc::tclcore punk::aliascore }] + #dictutils #pattern looks up versions available of patternlib before loading (but we don't have an index for tm files) todo fix pattern. # patterncmd\ @@ -3784,7 +3790,7 @@ namespace eval repl { #puts stderr "loading natsort" #natsort has 'application mode' which can exit. #Requiring it shouldn't trigger application - but zipfs/vfs interactions confused it in some early versions - package require natsort + #package require natsort #package require punk ;# Thread #package require shellrun ;#subcommand exists of file @@ -3794,7 +3800,7 @@ namespace eval repl { package require punk::ns ;#requires:punk::lib,punk::args,struct::list,cmdline+(tcllibc),struct::set,punk::ansi,punk::char, #textutil,textutil::string,textutil::adjust,textutil::repeat,textutil::string,textutil::split,textutil::tabify,textutil::wcswidth #punk::encmime,punk::assertion - #twapi,platform,registry,debug,overtype,patternpunk,pattern,patterncmd,metaface,patternpredator2,patternlib,dictutils + #twapi,platform,registry,debug,overtype,patternpunk,pattern,patterncmd,metaface,patternpredator2,patternlib #----------------------------------------------------------------------------------------------------------------------------------------- #package require textblock @@ -3921,7 +3927,7 @@ namespace eval repl { #puts stderr "loading natsort" #natsort has 'application mode' which can exit. #Requiring it shouldn't trigger application - but zipfs/vfs interactions confused it in some early versions - package require natsort + #package require natsort #catch {package require packageTrace} if {[catch {package require punk::console} errM]} { #review diff --git a/src/modules/punk/repo-999999.0a1.0.tm b/src/modules/punk/repo-999999.0a1.0.tm index de3bd201..93c02e17 100644 --- a/src/modules/punk/repo-999999.0a1.0.tm +++ b/src/modules/punk/repo-999999.0a1.0.tm @@ -83,6 +83,7 @@ namespace eval punk::repo { proc get_fossil_usage {} { set allcmds [runout -n fossil help -a] + #review - fix runout which is introducing addition ansi (repl problem?) set allcmds [punk::ansi::ansistrip $allcmds] set mainhelp [runout -n fossil help] set mainhelp [punk::ansi::ansistrip $mainhelp] @@ -190,7 +191,7 @@ namespace eval punk::repo { foreach ln $basic_opt_lines { set ln [string trim $ln] - #fossil sometimes emits cursor control sequences e.g CSI 3 q + #REVIEW - we only need to strip because 'runout' is introducing ansi. set ln [punk::ansi::ansistrip $ln] if {$ln eq ""} { continue diff --git a/src/modules/punkapp-0.1.tm b/src/modules/punkapp-999999.0a1.0.tm similarity index 99% rename from src/modules/punkapp-0.1.tm rename to src/modules/punkapp-999999.0a1.0.tm index 70fa90fc..9e700c96 100644 --- a/src/modules/punkapp-0.1.tm +++ b/src/modules/punkapp-999999.0a1.0.tm @@ -1,9 +1,5 @@ #utilities for punk apps to call -package provide punkapp [namespace eval punkapp { - variable version - set version 0.1 -}] namespace eval punkapp { variable result @@ -237,3 +233,8 @@ namespace eval punkapp { } } + +package provide punkapp [namespace eval punkapp { + variable version + set version 999999.0a1.0 +}] \ No newline at end of file diff --git a/src/modules/punkapp-buildversion.txt b/src/modules/punkapp-buildversion.txt new file mode 100644 index 00000000..c3ca4d16 --- /dev/null +++ b/src/modules/punkapp-buildversion.txt @@ -0,0 +1,3 @@ +0.1.1 +#First line must be a semantic version number +#all other lines are ignored. \ No newline at end of file diff --git a/src/modules/punkcheck-0.1.0.tm b/src/modules/punkcheck-999999.0a1.0.tm similarity index 99% rename from src/modules/punkcheck-0.1.0.tm rename to src/modules/punkcheck-999999.0a1.0.tm index 86823a45..9d5ffd84 100644 --- a/src/modules/punkcheck-0.1.0.tm +++ b/src/modules/punkcheck-999999.0a1.0.tm @@ -2454,6 +2454,6 @@ namespace eval ::punk::args::register { package provide punkcheck [namespace eval punkcheck { set pkg punkcheck variable version - set version 0.1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punkcheck-buildversion.txt b/src/modules/punkcheck-buildversion.txt new file mode 100644 index 00000000..c3ca4d16 --- /dev/null +++ b/src/modules/punkcheck-buildversion.txt @@ -0,0 +1,3 @@ +0.1.1 +#First line must be a semantic version number +#all other lines are ignored. \ No newline at end of file diff --git a/src/modules/punkcheck/cli-999999.0a1.0.tm b/src/modules/punkcheck/cli-999999.0a1.0.tm index 5ebac789..4d5ce964 100644 --- a/src/modules/punkcheck/cli-999999.0a1.0.tm +++ b/src/modules/punkcheck/cli-999999.0a1.0.tm @@ -64,7 +64,7 @@ namespace eval punkcheck::cli { #vfs can mask mounted files - so we can't just use 'file type' or glob with -type f ##set files [glob -nocomplain -dir $fullpath -type f *] package require punk::nav::fs - + #TODO - get all files in tree!!! set folderinfo [punk::nav::fs::dirfiles_dict $fullpath] set files [concat [dict get $folderinfo files] [dict get $folderinfo underlayfiles]] @@ -81,7 +81,7 @@ namespace eval punkcheck::cli { foreach p $punkcheck_files { set basedir [file dirname $p] set recordlist [punkcheck::load_records_from_file $p] - set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] + set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] foreach f $files { set relpath [punkcheck::lib::path_relative $basedir $f] @@ -137,13 +137,13 @@ namespace eval punkcheck::cli { } } } - } + } } if {[llength $source_files]} { - append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" + append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" } if {[llength $source_folders]} { - append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" + append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" } append pcheck \n @@ -152,7 +152,7 @@ namespace eval punkcheck::cli { } } } - append table "$f $pcheck" \n + append table "$f $pcheck" \n } } } @@ -182,7 +182,7 @@ namespace eval punkcheck::cli { foreach p $punkcheck_files { set basedir [file dirname $p] set recordlist [punkcheck::load_records_from_file $p] - set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] + set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] foreach f $files { set relpath [punkcheck::lib::path_relative $basedir $f] @@ -235,13 +235,13 @@ namespace eval punkcheck::cli { } } } - } + } } if {[llength $source_files]} { - append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" + append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" } if {[llength $source_folders]} { - append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" + append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" } append pcheck \n @@ -250,7 +250,7 @@ namespace eval punkcheck::cli { } } } - append table "$f $pcheck" \n + append table "$f $pcheck" \n } } } @@ -259,14 +259,13 @@ namespace eval punkcheck::cli { } - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punkcheck::cli::lib { namespace path ::punk::mix::util ;#askuser, do_in_path, foreach-file etc proc find_nearest_file {{path {}}} { if {$path eq {}} { set path [pwd] } - set folder [lib::scanup $path lib::is_punkchecked_folder] + set folder [lib::scanup $path lib::is_punkchecked_folder] if {$folder eq ""} { return "" } else { @@ -307,7 +306,6 @@ namespace eval punkcheck::cli::lib { } return {} } - } @@ -320,15 +318,15 @@ namespace eval punkcheck::cli { variable default_command status package require punk::mix::base package require punk::overlay - punk::overlay::custom_from_base [namespace current] ::punk::mix::base + punk::overlay::custom_from_base [namespace current] ::punk::mix::base } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punkcheck::cli [namespace eval punkcheck::cli { variable version - set version 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/shellrun-0.1.1.tm b/src/modules/shellrun-999999.0a1.0.tm similarity index 99% rename from src/modules/shellrun-0.1.1.tm rename to src/modules/shellrun-999999.0a1.0.tm index 96c578cd..7f880307 100644 --- a/src/modules/shellrun-0.1.1.tm +++ b/src/modules/shellrun-999999.0a1.0.tm @@ -893,5 +893,5 @@ namespace eval ::punk::args::register { package provide shellrun [namespace eval shellrun { variable version - set version 0.1.1 + set version 999999.0a1.0 }] diff --git a/src/modules/shellrun-buildversion.txt b/src/modules/shellrun-buildversion.txt new file mode 100644 index 00000000..c98e34df --- /dev/null +++ b/src/modules/shellrun-buildversion.txt @@ -0,0 +1,3 @@ +0.1.2 +#First line must be a semantic version number +#all other lines are ignored. \ No newline at end of file diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index e5d6500f..84f3caf8 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -6475,6 +6475,58 @@ tcl::namespace::eval textblock { } } variable framedef_cache [tcl::dict::create] + namespace eval argdoc { + set DYN_FRAME_TYPES {${[set ::textblock::frametypes]}} + punk::args::define { + @dynamic + @id -id ::textblock::framedef + @cmd -name textblock::framedef\ + -summary "Return frame graphical elements as a dictionary."\ + -help "Return a dict of the elements that make up a frame border. + May return a subset of available elements based on memberglob values." + @leaders -min 0 -max 0 + @opts + -joins -default "" -type list\ + -help "List of join directions, any of: up down left right + or those combined with another frametype e.g left-heavy down-light." + -boxonly -default 0 -type boolean\ + -help "-boxonly true restricts results to the corner,vertical and horizontal box elements + It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." + + @values -min 1 -max -1 + frametype -choices "${$DYN_FRAME_TYPES}" -choiceprefix 0 -choicerestricted 0 -type dict\ + -help "name from the predefined frametypes or an adhoc dictionary." + memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { + corner noncorner top bottom vertical horizontal left right + hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj + }\ + -help "restrict to keys matching memberglob." + } + #set spec [string map [list $::textblock::frametypes] { + # @id -id ::textblock::framedef + # @cmd -name textblock::framedef\ + # -summary "Return frame graphical elements as a dictionary."\ + # -help "Return a dict of the elements that make up a frame border. + # May return a subset of available elements based on memberglob values." + # @leaders -min 0 -max 0 + # @opts + # -joins -default "" -type list\ + # -help "List of join directions, any of: up down left right + # or those combined with another frametype e.g left-heavy down-light." + # -boxonly -default 0 -type boolean\ + # -help "-boxonly true restricts results to the corner,vertical and horizontal box elements + # It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." + + # @values -min 1 -max -1 + # frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ + # -help "name from the predefined frametypes or an adhoc dictionary." + # memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { + # corner noncorner top bottom vertical horizontal left right + # hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj + # }\ + # -help "restrict to keys matching memberglob." + #}] + } proc framedef {args} { #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. #e.g with characters such as \u2539 Box Drawings Right Light and Left Up Heavy. @@ -6520,6 +6572,9 @@ tcl::namespace::eval textblock { } } set f [lindex $values 0] + #expect either a known frametype or a dict with known keys + + set rawglobs [lrange $values 1 end] if {![llength $rawglobs] || "all" in $rawglobs || "*" in $rawglobs} { set globs * @@ -6570,32 +6625,7 @@ tcl::namespace::eval textblock { } if {$bad_option || [llength $values] == 0} { #no framedef supplied, or unrecognised opt seen - set spec [string map [list $::textblock::frametypes] { - @id -id ::textblock::framedef - @cmd -name textblock::framedef\ - -summary "Return frame graphical elements as a dictionary."\ - -help "Return a dict of the elements that make up a frame border. - May return a subset of available elements based on memberglob values." - @leaders -min 0 -max 0 - @opts - -joins -default "" -type list\ - -help "List of join directions, any of: up down left right - or those combined with another frametype e.g left-heavy down-light." - -boxonly -default 0 -type boolean\ - -help "-boxonly true restricts results to the corner,vertical and horizontal box elements - It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." - - @values -min 1 -max -1 - frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ - -help "name from the predefined frametypes or an adhoc dictionary." - memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { - corner noncorner top bottom vertical horizontal left right - hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj - }\ - -help "restrict to keys matching memberglob." - }] - #append spec \n "frametype -help \"A predefined \"" - punk::args::parse $args withdef $spec + punk::args::parse $args withid ::textblock::framedef return } @@ -7837,16 +7867,23 @@ tcl::namespace::eval textblock { set blc \U1fb7c ;#legacy block set brc \U1fb7f ;#legacy block - if {(![interp issafe])} { - if {![catch {punk::console::check::has_bug_legacysymbolwidth} symbug] && $symbug} { - #rather than totally fail on some mixed layout that happens to use block2 - just degrade it - but prevent alignment problems - set sp \u00a0 ;#non breaking space (plain space may act transparent in some use cases) - set tlc $sp - set trc $sp - set blc $sp - set brc $sp - } - } + + #------------------------------------------------------------------------------------------------------ + #REVIEW - framedef may be called in a context where we don't have a console that can respond to ansi queries. + #We should either check has_bug_legacysymbolwidth at initial console detection and set a global var, + #or find some other way to detect if we are in a terminal that has this problem. + + #if {(![interp issafe])} { + # if {![catch {punk::console::check::has_bug_legacysymbolwidth} symbug] && $symbug} { + # #rather than totally fail on some mixed layout that happens to use block2 - just degrade it - but prevent alignment problems + # set sp \u00a0 ;#non breaking space (plain space may act transparent in some use cases) + # set tlc $sp + # set trc $sp + # set blc $sp + # set brc $sp + # } + #} + #------------------------------------------------------------------------------------------------------ #horizontal and vertical bar joins set hltj $hlt @@ -7909,22 +7946,30 @@ tcl::namespace::eval textblock { set vlrj $vlr } default { + if {[llength $f] % 2 != 0} { + #todo - retrieve usage from punk::args + #error "textblock::frametype frametype '$f' is not one of the predefined frametypes: $::textblock::frametypes and does not appear to be a dictionary for a custom frametype" + punk::args::parse $args withid ::textblock::framedef + return + } + #set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] ;#only default the general types - these form defaults for more specific types if they're missing set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] if {"all" in [dict keys $f]} { set A [dict get $f all] set default_custom [tcl::dict::create hl $A vl $A tlc $A trc $A blc $A brc $A] } - if {[llength $f] % 2} { - #todo - retrieve usage from punk::args - error "textblock::frametype frametype '$f' is not one of the predefined frametypes: $::textblock::frametypes and does not appear to be a dictionary for a custom frametype" - } + #### #unknown order of keys specified by user - validate before creating vars as we need more general elements to be available as defaults dict for {k v} $f { switch -- $k { all - hl - vl - tlc - trc - blc - brc - hlt - hlb - vll - vlr - hltj - hlbj - vllj - vlrj {} default { - error "textblock::frametype '$f' has unknown element '$k'" + #error "textblock::frametype '$f' has unknown element '$k'" + set errmsg [punk::args::usage -scheme error ::textblock::framedef] + append errmsg "\ntextblock::frametype frametype '$f' has unknown element '$k'" + error $errmsg + return } } } diff --git a/src/modules/zzzload-999999.0a1.0.tm b/src/modules/zzzload-999999.0a1.0.tm index 2631d282..506b7a1c 100644 --- a/src/modules/zzzload-999999.0a1.0.tm +++ b/src/modules/zzzload-999999.0a1.0.tm @@ -9,7 +9,7 @@ # @@ Meta Begin # Application zzzload 999999.0a1.0 # Meta platform tcl -# Meta license BSD +# Meta license BSD # @@ Meta End @@ -20,6 +20,7 @@ package require Thread +#EXPERIMENTAL. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval zzzload { @@ -63,6 +64,8 @@ namespace eval zzzload { } if {$loader_tid eq ""} { set loader_tid [thread::create -joinable -preserved] + #todo - set tcl::tm::list and ::auto_path in the loader thread to match the main thread. + #(startup process may have modified these paths) } if {![tsv::exists zzzload_pkg $pkgname]} { #puts stderr "zzzload pkg_require $pkgname" @@ -73,7 +76,7 @@ namespace eval zzzload { tsv::set zzzload_pkg_cond $pkgname $cond thread::send -async $loader_tid [string map [list $pkgname $cond] { if {![catch {package require } returnver]} { - tsv::set zzzload_pkg $returnver + tsv::set zzzload_pkg $returnver } else { tsv::set zzzload_pkg "failed" } @@ -85,7 +88,7 @@ namespace eval zzzload { } } proc pkg_wait {pkgname} { - if {[set ver [package provide twapi]] ne ""} { + if {[set ver [package provide $pkgname]] ne ""} { return $ver } @@ -116,22 +119,10 @@ namespace eval zzzload { } - - - - - - - - - - - - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide zzzload [namespace eval zzzload { variable version - set version 999999.0a1.0 + set version 999999.0a1.0 }] return \ No newline at end of file