diff --git a/src/bootsupport/modules/fauxlink-0.1.0.tm b/src/bootsupport/modules/fauxlink-0.1.0.tm index d0fdc8ec..a94a5b9c 100644 --- a/src/bootsupport/modules/fauxlink-0.1.0.tm +++ b/src/bootsupport/modules/fauxlink-0.1.0.tm @@ -53,8 +53,8 @@ #[para] Others that require encoding are: * ? \ / | : ; " < > #[para] The nul character in raw form, when detected, is always mapped away to the empty string - as very few filesystems support it. #[para] Control characters and other punctuation is optional to encode. -#[para] Generally utf-8 should be used where possible and unicode characters left as is where possible on modern systems. -#[para] Where encoding of unicode is desired in the nominalname or encodedtarget portions it can be specified as %UXXXXXXXX +#[para] Generally utf-8 should be used where possible and unicode characters can often be left unencoded on modern systems. +#[para] Where encoding of unicode is desired in the nominalname,encodedtarget,tag or comment portions it can be specified as %UXXXXXXXX #[para] There must be between 1 and 8 X digits following the %U. Interpretation of chars following %U stops at the first non-hex character. #[para] This means %Utest would not get any translation as there were no hex digits so it would come out as %Utest # @@ -267,43 +267,71 @@ namespace eval fauxlink { #[subsection {Namespace fauxlink}] #[para] Core API functions for fauxlink #[list_begin definitions] + proc Segment_mustencode_check {str} { + variable decode_map + variable encode_map ;#must_encode + set idx 0 + set err "" + foreach ch [split $str ""] { + if {[dict exists $encode_map $ch]} { + set enc [dict get $encode_map $ch] + if {[dict exists $decode_map $enc]} { + append err " char $idx should be encoded as $enc" \n + } else { + append err " no %xx encoding available. Use %UXX if really required" \n + } + } + incr idx + } + return $err ;#empty string if ok + } proc resolve {link} { variable decode_map variable encode_map variable must_encode set ftail [file tail $link] - if {[file extension $ftail] ni [list .fxlnk .fauxlink]} { - error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" - } + set extension_name [string range [file extension $ftail] 1 end] + if {$extension_name ni [list fxlnk fauxlink]} { + set is_fauxlink 0 + #we'll process anyway - but return the result wrapped + #This should allow deliberate erroring for the calling dict user if the extension difference is inadvertent + #(e.g blindly processing all files in a folder that is normally only .fxlnk files - but then something added that happens + # to have # characters in it) + #It also means if someone really wants to use the fauxlink semantics on a different file type + # - they can - but just have to access the results differently and take that (minor) risk. + #error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" + set err_extra "\nnonstandard extension '$extension_name' for fauxlink. Check that the call to fauxlink::resolve was deliberate" + } else { + set is_fauxlink 1 + set err_extra "" + } set linkspec [file rootname $ftail] # - any # or + within the target path or name should have been uri encoded as %23 and %2b if {[tcl::string::first # $linkspec] < 0} { - error "fauxlink::resolve error. Link must contain a # (usually at start if name matches target)" + set err "fauxlink::resolve '$link'. Link must contain a # (usually at start if name matches target)" + append err $err_extra + error $err } - #only the 1st 2 parts of split on # are significant. - #if there are more # chars present - the subsequent parts are effectively a comment - - #check namepec already has required chars encoded - lassign [split $linkspec #] namespec targetspec + #The 1st 2 parts of split on # are name and target file/dir + #If there are only 3 parts the 3rd part is a comment and there are no 'tags' + #if there are 4 parts - the 3rd part is a tagset where each tag begins with @ + #and each subsequent part is a comment. Empty comments are stripped from the comments list + #A tagset can be empty - but if it's not empty it must contain at least one @ and must start with @ + #e.g name.txt#path#@tag1@tag2#test###.fxlnk + #has a name, a target, 2 tags and one comment + + #check namespec already has required chars encoded + set segments [split $linkspec #] + lassign $segments namespec targetspec #puts stderr "-->namespec $namespec" set nametest [tcl::string::map $encode_map $namespec] #puts stderr "-->nametest $nametest" #nothing should be changed - if there are unencoded chars that must be encoded it is an error if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} { - set err "fauxlink::resolve invalid chars in name part (section prior to first #)" - set idx 0 - foreach ch [split $namespec ""] { - if {$ch in $must_encode} { - set enc [dict get $encode_map $ch] - if {[dict exists $decode_map $enc]} { - append err " char $idx should be encoded as $enc" \n - } else { - append err " no %xx encoding available. Use %UXX if really required" \n - } - } - incr idx - } + set err "fauxlink::resolve '$link' invalid chars in name part (section prior to first #)" + append err [Segment_mustencode_check $namespec] + append err $err_extra error $err } #see comments below regarding 2 rounds and ordering. @@ -313,24 +341,14 @@ namespace eval fauxlink { set targetsegment [split $targetspec +] #check each + delimited part of targetspec already has required chars encoded - set s 0 ;#segment index - set result_segments [list] - foreach segment $targetsegment { - set targettest [tcl::string::map $encode_map $segment] - if {[tcl::string::length $targettest] ne [tcl::string::length $segment]} { - set err "fauxlink::resolve invalid chars in targetpath (section following first #)" - set idx 0 - foreach ch [split $segment ""] { - if {$ch in $must_encode} { - set enc [dict get $encode_map $ch] - if {[dict exists $decode_map $enc]} { - append err " segment $s char $idx should be encoded as $enc" \n - } else { - append err " no %xx encoding available. Use %UXX if really required" \n - } - } - incr idx - } + set pp 0 ;#pathpart index + set targetpath_parts [list] + foreach pathpart $targetsegment { + set targettest [tcl::string::map $encode_map $pathpart] + if {[tcl::string::length $targettest] ne [tcl::string::length $pathpart]} { + set err "fauxlink::resolve '$link' invalid chars in targetpath (section following first #)" + append err [Segment_mustencode_check $pathpart] + append err $err_extra error $err } #2 rounds of substitution is possibly asking for trouble.. @@ -343,18 +361,89 @@ namespace eval fauxlink { #we do unicode first - as a 2nd round of %XX substitutions is unlikely to interfere. #There is still the opportunity to use things like %U00000025 followed by hex-chars # and get some minor surprises, but using %U on ascii is unlikely to be done accidentally - REVIEW - set segment [decode_unicode_escapes $segment] - set segment [tcl::string::map $decode_map $segment] - lappend result_segments $segment + set pathpart [decode_unicode_escapes $pathpart] + set pathpart [tcl::string::map $decode_map $pathpart] + lappend targetpath_parts $pathpart - incr s + incr pp } - set targetpath [join $result_segments /] + set targetpath [join $targetpath_parts /] if {$name eq ""} { - set name [lindex $result_segments end] + set name [lindex $targetpath_parts end] + } + #we do the same encoding checks on tags and comments to increase chances of portability + set tags [list] + set comments [list] + switch -- [llength $segments] { + 2 { + #no tags or comments + } + 3 { + #only 3 sections - last is comment - even if looks like tags + #to make the 3rd part a tagset, an extra # would be needed + set comments [list [lindex $segments 2]] + } + default { + set tagset [lindex $segments 2] + if {$tagset eq ""} { + #ok - no tags + } else { + if {[string first @ $tagset] != 0} { + set err "fauxlink::resolve '$link' invalid tagset in 3rd #-delimited segment" + append err \n " - must begin with @" + append err $err_extra + error $err + } else { + set tagset [string range $tagset 1 end] + set rawtags [split $tagset @] + set tags [list] + foreach t $rawtags { + if {$t eq ""} { + lappend tags "" + } else { + set tagtest [tcl::string::map $encode_map $t] + if {[tcl::string::length $tagtest] ne [tcl::string::length $t]} { + set err "fauxlink::resolve '$link' invalid chars in tag [llength $tags]" + append err [Segment_mustencode_check $t] + append err $err_extra + error $err + } + lappend tags [tcl::string::map $decode_map [decode_unicode_escapes $t]] + } + } + } + } + set rawcomments [lrange $segments 3 end] + #set comments [lsearch -all -inline -not $comments ""] + set comments [list] + foreach c $rawcomments { + if {$c eq ""} {continue} + set commenttest [tcl::string::map $encode_map $c] + if {[tcl::string::length $commenttest] ne [tcl::string::length $c]} { + set err "fauxlink::resolve '$link' invalid chars in comment [llength $comments]" + append err [Segment_mustencode_check $c] + append err $err_extra + error $err + } + lappend comments [tcl::string::map $decode_map [decode_unicode_escapes $c]] + } + } } - return [dict create name $name targetpath $targetpath] + set data [dict create name $name targetpath $targetpath tags $tags comments $comments fauxlinkextension $extension_name] + if {$is_fauxlink} { + #standard .fxlnk or .fauxlink + return $data + } else { + #custom extension - or called in error on wrong type of file but happened to parse. + #see comments at top regarding is_fauxlink + #make sure no keys in common at top level. + return [dict create\ + linktype $extension_name\ + note "nonstandard extension returning nonstandard dict with result in data key"\ + data $data\ + ] + } } variable map diff --git a/src/vendormodules/fauxlink-0.1.0.tm b/src/bootsupport/modules/fauxlink-0.1.1.tm similarity index 67% rename from src/vendormodules/fauxlink-0.1.0.tm rename to src/bootsupport/modules/fauxlink-0.1.1.tm index d0fdc8ec..7aff6ec0 100644 --- a/src/vendormodules/fauxlink-0.1.0.tm +++ b/src/bootsupport/modules/fauxlink-0.1.1.tm @@ -7,7 +7,7 @@ # (C) 2024 # # @@ Meta Begin -# Application fauxlink 0.1.0 +# Application fauxlink 0.1.1 # Meta platform tcl # Meta license MIT # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin fauxlink_module_fauxlink 0 0.1.0] +#[manpage_begin fauxlink_module_fauxlink 0 0.1.1] #[copyright "2024"] #[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}] #[moddesc {fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] @@ -53,8 +53,8 @@ #[para] Others that require encoding are: * ? \ / | : ; " < > #[para] The nul character in raw form, when detected, is always mapped away to the empty string - as very few filesystems support it. #[para] Control characters and other punctuation is optional to encode. -#[para] Generally utf-8 should be used where possible and unicode characters left as is where possible on modern systems. -#[para] Where encoding of unicode is desired in the nominalname or encodedtarget portions it can be specified as %UXXXXXXXX +#[para] Generally utf-8 should be used where possible and unicode characters can often be left unencoded on modern systems. +#[para] Where encoding of unicode is desired in the nominalname,encodedtarget,tag or comment portions it can be specified as %UXXXXXXXX #[para] There must be between 1 and 8 X digits following the %U. Interpretation of chars following %U stops at the first non-hex character. #[para] This means %Utest would not get any translation as there were no hex digits so it would come out as %Utest # @@ -267,43 +267,71 @@ namespace eval fauxlink { #[subsection {Namespace fauxlink}] #[para] Core API functions for fauxlink #[list_begin definitions] + proc Segment_mustencode_check {str} { + variable decode_map + variable encode_map ;#must_encode + set idx 0 + set err "" + foreach ch [split $str ""] { + if {[dict exists $encode_map $ch]} { + set enc [dict get $encode_map $ch] + if {[dict exists $decode_map $enc]} { + append err " char $idx should be encoded as $enc" \n + } else { + append err " no %xx encoding available. Use %UXX if really required" \n + } + } + incr idx + } + return $err ;#empty string if ok + } proc resolve {link} { variable decode_map variable encode_map variable must_encode set ftail [file tail $link] - if {[file extension $ftail] ni [list .fxlnk .fauxlink]} { - error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" - } + set extension_name [string range [file extension $ftail] 1 end] + if {$extension_name ni [list fxlnk fauxlink]} { + set is_fauxlink 0 + #we'll process anyway - but return the result wrapped + #This should allow deliberate erroring for the calling dict user if the extension difference is inadvertent + #(e.g blindly processing all files in a folder that is normally only .fxlnk files - but then something added that happens + # to have # characters in it) + #It also means if someone really wants to use the fauxlink semantics on a different file type + # - they can - but just have to access the results differently and take that (minor) risk. + #error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" + set err_extra "\nnonstandard extension '$extension_name' for fauxlink. Check that the call to fauxlink::resolve was deliberate" + } else { + set is_fauxlink 1 + set err_extra "" + } set linkspec [file rootname $ftail] # - any # or + within the target path or name should have been uri encoded as %23 and %2b if {[tcl::string::first # $linkspec] < 0} { - error "fauxlink::resolve error. Link must contain a # (usually at start if name matches target)" + set err "fauxlink::resolve '$link'. Link must contain a # (usually at start if name matches target)" + append err $err_extra + error $err } - #only the 1st 2 parts of split on # are significant. - #if there are more # chars present - the subsequent parts are effectively a comment - - #check namepec already has required chars encoded - lassign [split $linkspec #] namespec targetspec + #The 1st 2 parts of split on # are name and target file/dir + #If there are only 3 parts the 3rd part is a comment and there are no 'tags' + #if there are 4 parts - the 3rd part is a tagset where each tag begins with @ + #and each subsequent part is a comment. Empty comments are stripped from the comments list + #A tagset can be empty - but if it's not empty it must contain at least one @ and must start with @ + #e.g name.txt#path#@tag1@tag2#test###.fxlnk + #has a name, a target, 2 tags and one comment + + #check namespec already has required chars encoded + set segments [split $linkspec #] + lassign $segments namespec targetspec #puts stderr "-->namespec $namespec" set nametest [tcl::string::map $encode_map $namespec] #puts stderr "-->nametest $nametest" #nothing should be changed - if there are unencoded chars that must be encoded it is an error if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} { - set err "fauxlink::resolve invalid chars in name part (section prior to first #)" - set idx 0 - foreach ch [split $namespec ""] { - if {$ch in $must_encode} { - set enc [dict get $encode_map $ch] - if {[dict exists $decode_map $enc]} { - append err " char $idx should be encoded as $enc" \n - } else { - append err " no %xx encoding available. Use %UXX if really required" \n - } - } - incr idx - } + set err "fauxlink::resolve '$link' invalid chars in name part (section prior to first #)" + append err [Segment_mustencode_check $namespec] + append err $err_extra error $err } #see comments below regarding 2 rounds and ordering. @@ -313,24 +341,14 @@ namespace eval fauxlink { set targetsegment [split $targetspec +] #check each + delimited part of targetspec already has required chars encoded - set s 0 ;#segment index - set result_segments [list] - foreach segment $targetsegment { - set targettest [tcl::string::map $encode_map $segment] - if {[tcl::string::length $targettest] ne [tcl::string::length $segment]} { - set err "fauxlink::resolve invalid chars in targetpath (section following first #)" - set idx 0 - foreach ch [split $segment ""] { - if {$ch in $must_encode} { - set enc [dict get $encode_map $ch] - if {[dict exists $decode_map $enc]} { - append err " segment $s char $idx should be encoded as $enc" \n - } else { - append err " no %xx encoding available. Use %UXX if really required" \n - } - } - incr idx - } + set pp 0 ;#pathpart index + set targetpath_parts [list] + foreach pathpart $targetsegment { + set targettest [tcl::string::map $encode_map $pathpart] + if {[tcl::string::length $targettest] ne [tcl::string::length $pathpart]} { + set err "fauxlink::resolve '$link' invalid chars in targetpath (section following first #)" + append err [Segment_mustencode_check $pathpart] + append err $err_extra error $err } #2 rounds of substitution is possibly asking for trouble.. @@ -343,18 +361,89 @@ namespace eval fauxlink { #we do unicode first - as a 2nd round of %XX substitutions is unlikely to interfere. #There is still the opportunity to use things like %U00000025 followed by hex-chars # and get some minor surprises, but using %U on ascii is unlikely to be done accidentally - REVIEW - set segment [decode_unicode_escapes $segment] - set segment [tcl::string::map $decode_map $segment] - lappend result_segments $segment + set pathpart [decode_unicode_escapes $pathpart] + set pathpart [tcl::string::map $decode_map $pathpart] + lappend targetpath_parts $pathpart - incr s + incr pp } - set targetpath [join $result_segments /] + set targetpath [join $targetpath_parts /] if {$name eq ""} { - set name [lindex $result_segments end] + set name [lindex $targetpath_parts end] + } + #we do the same encoding checks on tags and comments to increase chances of portability + set tags [list] + set comments [list] + switch -- [llength $segments] { + 2 { + #no tags or comments + } + 3 { + #only 3 sections - last is comment - even if looks like tags + #to make the 3rd part a tagset, an extra # would be needed + set comments [list [lindex $segments 2]] + } + default { + set tagset [lindex $segments 2] + if {$tagset eq ""} { + #ok - no tags + } else { + if {[string first @ $tagset] != 0} { + set err "fauxlink::resolve '$link' invalid tagset in 3rd #-delimited segment" + append err \n " - must begin with @" + append err $err_extra + error $err + } else { + set tagset [string range $tagset 1 end] + set rawtags [split $tagset @] + set tags [list] + foreach t $rawtags { + if {$t eq ""} { + lappend tags "" + } else { + set tagtest [tcl::string::map $encode_map $t] + if {[tcl::string::length $tagtest] ne [tcl::string::length $t]} { + set err "fauxlink::resolve '$link' invalid chars in tag [llength $tags]" + append err [Segment_mustencode_check $t] + append err $err_extra + error $err + } + lappend tags [tcl::string::map $decode_map [decode_unicode_escapes $t]] + } + } + } + } + set rawcomments [lrange $segments 3 end] + #set comments [lsearch -all -inline -not $comments ""] + set comments [list] + foreach c $rawcomments { + if {$c eq ""} {continue} + set commenttest [tcl::string::map $encode_map $c] + if {[tcl::string::length $commenttest] ne [tcl::string::length $c]} { + set err "fauxlink::resolve '$link' invalid chars in comment [llength $comments]" + append err [Segment_mustencode_check $c] + append err $err_extra + error $err + } + lappend comments [tcl::string::map $decode_map [decode_unicode_escapes $c]] + } + } } - return [dict create name $name targetpath $targetpath] + set data [dict create name $name targetpath $targetpath tags $tags comments $comments fauxlinkextension $extension_name] + if {$is_fauxlink} { + #standard .fxlnk or .fauxlink + return $data + } else { + #custom extension - or called in error on wrong type of file but happened to parse. + #see comments at top regarding is_fauxlink + #make sure no keys in common at top level. + return [dict create\ + linktype $extension_name\ + note "nonstandard extension returning nonstandard dict with result in data key"\ + data $data\ + ] + } } variable map @@ -469,7 +558,7 @@ namespace eval fauxlink::system { package provide fauxlink [namespace eval fauxlink { variable pkg fauxlink variable version - set version 0.1.0 + set version 0.1.1 }] return diff --git a/src/bootsupport/modules/include_modules.config b/src/bootsupport/modules/include_modules.config index dbd5e50c..158166cf 100644 --- a/src/bootsupport/modules/include_modules.config +++ b/src/bootsupport/modules/include_modules.config @@ -90,5 +90,6 @@ set bootsupport_modules [list\ modules textblock\ modules natsort\ modules oolib\ + modules zipper\ ] diff --git a/src/vendormodules/modpod-0.1.0.tm b/src/bootsupport/modules/modpod-0.1.1.tm similarity index 75% rename from src/vendormodules/modpod-0.1.0.tm rename to src/bootsupport/modules/modpod-0.1.1.tm index fd6b00ec..afa3be2a 100644 --- a/src/vendormodules/modpod-0.1.0.tm +++ b/src/bootsupport/modules/modpod-0.1.1.tm @@ -7,7 +7,7 @@ # (C) 2024 # # @@ Meta Begin -# Application modpod 0.1.0 +# Application modpod 0.1.1 # Meta platform tcl # Meta license # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.0] +#[manpage_begin modpod_module_modpod 0 0.1.1] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] @@ -131,6 +131,7 @@ namespace eval modpod { # return "ok" #} + #old tar connect mechanism - review - not needed? proc connect {args} { puts stderr "modpod::connect--->>$args" set argd [punk::args::get_dict { @@ -152,11 +153,11 @@ namespace eval modpod { lappend connected(to) $modpodpath set connected(connectpath,$opt_path) $original_connectpath - set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info_script]]}] + set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] set connected(location,$modpodpath) [file dirname $modpodpath] set connected(startdata,$modpodpath) -1 - set connected(type,$modpodpath) [dict get $argd-opts -type] + set connected(type,$modpodpath) [dict get $argd opts -type] set connected(fh,$modpodpath) "" if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { @@ -269,7 +270,8 @@ namespace eval modpod { set filename [dict get $argd values filename] variable connected - set modpod [::tarjar::system::connect_if_not $frompod] + #//review + set modpod [::modpod::system::connect_if_not $frompod] set fh $connected(fh,$modpod) if {$connected(type,$modpod) eq "unwrapped"} { #for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder @@ -323,10 +325,28 @@ namespace eval modpod::lib { return 0 } } - proc make_zip_modpod {zipfile outfile} { - set mount_stub { - #zip file with Tcl loader prepended. - #generated using modpod::make_zip_modpod + + #zipfile is a pure zip at this point - ie no script/exe header + proc make_zip_modpod {args} { + set argd [punk::args::get_dict { + -offsettype -default "file" -choices {archive file} -help "Whether zip offsets are relative to start of file or start of zip-data within the file. + 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, + but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) + info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. + -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" + *values -min 2 -max 2 + zipfile -type path -minlen 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" + outfile -type path -minlen 1 -help "path to output file. Name should be of the form packagename-version.tm" + } $args] + set zipfile [dict get $argd values zipfile] + set outfile [dict get $argd values outfile] + set opt_offsettype [dict get $argd opts -offsettype] + + + set mount_stub [string map [list %offsettype% $opt_offsettype] { + #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. + #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. + #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% if {[catch {file normalize [info script]} modfile]} { error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" } @@ -362,7 +382,7 @@ namespace eval modpod::lib { foreach lc_mpath $lcase_modulepaths { set mpath_segments [file split $lc_mpath] if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use propertly cased tail + set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail break } } @@ -407,8 +427,8 @@ namespace eval modpod::lib { #NB. We don't create the intermediate dirs - but the mount still works if {![file exists $moddir/$mount_at]} { if {[catch {package require vfs::zip} errM]} { - set msg "Unable to load vfs::zip package to mount module $mod_and_ver" - append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place." + set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" + append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" error $msg } else { @@ -423,57 +443,12 @@ namespace eval modpod::lib { } } #zipped data follows - } - #todo - test if zipfile has #modpod-loadcript.tcl before even creating + }] + #todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub + modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype } - proc make_zip_modpod1 {zipfile outfile} { - set mount_stub { - #zip file with Tcl loader prepended. - #generated using modpod::make_zip_modpod - if {[catch {file normalize [info script]} modfile]} { - error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" - } - if {$modfile eq "" || ![file exists $modfile]} { - error "modpod zip stub error. Unable to determine module path" - } - set moddir [file dirname $modfile] - set mod_and_ver [file rootname [file tail $modfile]] - lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver]} { - source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - if {![file exists $moddir/#mounted-modpod-$mod_and_ver]} { - if {[catch {package require vfs::zip} errM]} { - set msg "Unable to load vfs::zip package to mount module $mod_and_ver" - append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place." - append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $ - } - set fd [vfs::zip::Mount $modfile $moddir/#mounted-modpod-$mod_and_ver] - if {![file exists $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - vfs::zip::Unmount $fd $moddir/#mounted-modpod-$mod_and_ver - error "Unable to find #modpod-$mod_and_ver/$mod_and_ver.tm in $modfile" - } - } - source $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm - } - #zipped data follows - } - #todo - test if zipfile has #modpod-loadcript.tcl before even creating - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub - - } - proc make_zip_source_mountable {zipfile outfile} { - set mount_stub { - package require vfs::zip - vfs::zip::Mount [info script] [info script] - } - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub - } #*** !doctools #[list_end] [comment {--- end definitions namespace modpod::lib ---}] @@ -491,107 +466,124 @@ namespace eval modpod::system { #[para] Internal functions that are not part of the API #deflate,store only supported - proc make_mountable_zip {zipfile outfile mount_stub} { - set in [open $zipfile r] - fconfigure $in -encoding iso8859-1 -translation binary + + #zipfile here is plain zip - no script/exe prefix part. + proc make_mountable_zip {zipfile outfile mount_stub {offsettype "file"}} { + set inzip [open $zipfile r] + fconfigure $inzip -encoding iso8859-1 -translation binary set out [open $outfile w+] fconfigure $out -encoding iso8859-1 -translation binary puts -nonewline $out $mount_stub - set offset [tell $out] - lappend report "sfx stub size: $offset" - fcopy $in $out - - close $in + set stuboffset [tell $out] + lappend report "sfx stub size: $stuboffset" + fcopy $inzip $out + close $inzip + set size [tell $out] - #Now seek in $out to find the end of directory signature: - #The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text - if {$size < 65559} { - set seek 0 - } else { - set seek [expr {$size - 65559}] - } - seek $out $seek - set data [read $out] - set start_of_end [string last "\x50\x4b\x05\x06" $data] - #set start_of_end [expr {$start_of_end + $seek}] - incr start_of_end $seek - - lappend report "START-OF-END: $start_of_end ([expr {$start_of_end - $size}]) [string length $data]" - - seek $out $start_of_end - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - lappend report "End of central directory: [array get eocd]" - seek $out [expr {$start_of_end+16}] - - #adjust offset of start of central directory by the length of our sfx stub - puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $offset}]] - flush $out - - seek $out $start_of_end - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - # 0x06054b50 - end of central dir signature - puts stderr "$end_of_ctrl_dir" - puts stderr "comment_len: $eocd(comment_len)" - puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" - lappend report "New dir offset: $eocd(diroffset)" - lappend report "Adjusting $eocd(totalnum) zip file items." - catch { - punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies - } - - seek $out $eocd(diroffset) - for {set i 0} {$i <$eocd(totalnum)} {incr i} { - set current_file [tell $out] - set fileheader [read $out 46] - puts -------------- - puts [ansistring VIEW -lf 1 $fileheader] - puts -------------- - #binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - # x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - - binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - set ::last_header $fileheader - - puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" - puts "ver: $x(version)" - puts "method: $x(method)" - - #33639248 dec = 0x02014b50 - central file header signature - if { $x(sig) != 33639248 } { - error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" + lappend report "tmfile : [file tail $outfile]" + lappend report "output size : $size" + lappend report "offsettype : $offsettype" + + if {$offsettype eq "file"} { + #make zip offsets relative to start of whole file including prepended script. + #(same offset structure as Tcl's 'zipfs mkimg' as at 2024-10) + #we aren't adding any new files/folders so we can edit the offsets in place + + #Now seek in $out to find the end of directory signature: + #The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text + if {$size < 65559} { + set tailsearch_start 0 + } else { + set tailsearch_start [expr {$size - 65559}] + } + seek $out $tailsearch_start + set data [read $out] + #EOCD - End of Central Directory record + #PK\5\6 + set start_of_end [string last "\x50\x4b\x05\x06" $data] + #set start_of_end [expr {$start_of_end + $seek}] + #incr start_of_end $seek + set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] + + lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" + + seek $out $filerelative_eocd_posn + set end_of_ctrl_dir [read $out] + binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + + lappend report "End of central directory: [array get eocd]" + seek $out [expr {$filerelative_eocd_posn+16}] + + #adjust offset of start of central directory by the length of our sfx stub + puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] + flush $out + + seek $out $filerelative_eocd_posn + set end_of_ctrl_dir [read $out] + binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + + # 0x06054b50 - end of central dir signature + puts stderr "$end_of_ctrl_dir" + puts stderr "comment_len: $eocd(comment_len)" + puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" + lappend report "New dir offset: $eocd(diroffset)" + lappend report "Adjusting $eocd(totalnum) zip file items." + catch { + punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies } - foreach size $x(lengths) var {filename extrafield comment} { - if { $size > 0 } { - set x($var) [read $out $size] - } else { - set x($var) "" + seek $out $eocd(diroffset) + for {set i 0} {$i <$eocd(totalnum)} {incr i} { + set current_file [tell $out] + set fileheader [read $out 46] + puts -------------- + puts [ansistring VIEW -lf 1 $fileheader] + puts -------------- + #binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + # x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + + binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + set ::last_header $fileheader + + puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" + puts "ver: $x(version)" + puts "method: $x(method)" + + #PK\1\2 + #33639248 dec = 0x02014b50 - central directory file header signature + if { $x(sig) != 33639248 } { + error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" } - } - set next_file [tell $out] - lappend report "file $i: $x(offset) $x(sizes) $x(filename)" + + foreach size $x(lengths) var {filename extrafield comment} { + if { $size > 0 } { + set x($var) [read $out $size] + } else { + set x($var) "" + } + } + set next_file [tell $out] + lappend report "file $i: $x(offset) $x(sizes) $x(filename)" + + seek $out [expr {$current_file+42}] + puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] - seek $out [expr {$current_file+42}] - puts -nonewline $out [binary format i [expr {$x(offset)+$offset}]] - - #verify: - flush $out - seek $out $current_file - set fileheader [read $out 46] - lappend report "old $x(offset) + $offset" - binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - lappend report "new $x(offset)" - - seek $out $next_file + #verify: + flush $out + seek $out $current_file + set fileheader [read $out 46] + lappend report "old $x(offset) + $stuboffset" + binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + lappend report "new $x(offset)" + + seek $out $next_file + } } + close $out #pdict/showdict reuire punk & textlib - ie lots of dependencies #don't fall over just because of that @@ -696,7 +688,7 @@ namespace eval modpod::system { package provide modpod [namespace eval modpod { variable pkg modpod variable version - set version 0.1.0 + set version 0.1.1 }] return diff --git a/src/bootsupport/modules/modpod-0.1.2.tm b/src/bootsupport/modules/modpod-0.1.2.tm new file mode 100644 index 00000000..166bd423 --- /dev/null +++ b/src/bootsupport/modules/modpod-0.1.2.tm @@ -0,0 +1,699 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application modpod 0.1.2 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin modpod_module_modpod 0 0.1.2] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require modpod] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of modpod +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by modpod +#[list_begin itemized] + +package require Tcl 8.6- +package require struct::set ;#review +package require punk::lib +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval modpod::class { + #*** !doctools + #[subsection {Namespace modpod::class}] + #[para] class definitions + if {[info commands [namespace current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval modpod { + namespace export {[a-z]*}; # Convention: export all lowercase + + variable connected + if {![info exists connected(to)]} { + set connected(to) list + } + variable modpodscript + set modpodscript [info script] + if {[string tolower [file extension $modpodscript]] eq ".tcl"} { + set connected(self) [file dirname $modpodscript] + } else { + #expecting a .tm + set connected(self) $modpodscript + } + variable loadables [info sharedlibextension] + variable sourceables {.tcl .tk} ;# .tm ? + + #*** !doctools + #[subsection {Namespace modpod}] + #[para] Core API functions for modpod + #[list_begin definitions] + + + + #proc sample1 {p1 args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [opt {?option value...?}]] + # #[para]Description of sample1 + # return "ok" + #} + + #old tar connect mechanism - review - not needed? + proc connect {args} { + puts stderr "modpod::connect--->>$args" + set argd [punk::args::get_dict { + -type -default "" + *values -min 1 -max 1 + path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" + } $args] + catch { + punk::lib::showdict $argd ;#heavy dependencies + } + set opt_path [dict get $argd values path] + variable connected + set original_connectpath $opt_path + set modpodpath [modpod::system::normalize $opt_path] ;# + + if {$modpodpath in $connected(to)} { + return [dict create ok ALREADY_CONNECTED] + } + lappend connected(to) $modpodpath + + set connected(connectpath,$opt_path) $original_connectpath + set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] + + set connected(location,$modpodpath) [file dirname $modpodpath] + set connected(startdata,$modpodpath) -1 + set connected(type,$modpodpath) [dict get $argd opts -type] + set connected(fh,$modpodpath) "" + + if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { + set connected(type,$modpodpath) "unwrapped" + lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] + + } else { + #connect to .tm but may still be unwrapped version available + lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + set this_pkg_tm_folder [file dirname $modpodpath] + if {$connected(type,$modpodpath) ne "unwrapped"} { + #Not directly connected to unwrapped version - but may still be redirected there + set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] + if {[file exists $unwrappedFolder]} { + #folder with exact version-match must exist for redirect to 'unwrapped' + set con(type,$modpodpath) "modpod-redirecting" + } + } + + } + set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" + set connected(tmfile,$modpodpath) + set tail_segments [list] + set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] + set lcase_modulepaths [string tolower [tcl::tm::list]] + foreach lc_mpath $lcase_modulepaths { + set mpath_segments [file split $lc_mpath] + if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { + set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] + break + } + } + if {[llength $tail_segments]} { + set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require + } else { + set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] + } + + switch -exact -- $connected(type,$modpodpath) { + "modpod-redirecting" { + #redirect to the unwrapped version + set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] + + } + "unwrapped" { + if {[info commands ::thread::id] ne ""} { + set from [pid],[thread::id] + } else { + set from [pid] + } + #::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" + return [list ok ""] + } + default { + #autodetect .tm - zip/tar ? + #todo - use vfs ? + + #connect to tarball - start at 1st header + set connected(startdata,$modpodpath) 0 + set fh [open $modpodpath r] + set connected(fh,$modpodpath) $fh + fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} + + if {$connected(startdata,$modpodpath) >= 0} { + #verify we have a valid tar header + if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { + seek $fh $connected(startdata,$modpodpath) start + return [list ok $fh] + } else { + #error "cannot verify tar header" + } + } + lpop connected(to) end + set connected(startdata,$modpodpath) -1 + unset connected(fh,$modpodpath) + catch {close $fh} + return [dict create err {Does not appear to be a valid modpod}] + } + } + } + proc disconnect {{modpod ""}} { + variable connected + if {![llength $connected(to)]} { + return 0 + } + if {$modpod eq ""} { + puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" + set modpod [lindex $connected(to) end] + } + + if {[set posn [lsearch $connected(to) $modpod]] == -1} { + puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" + return 0 + } + if {[string length $connected(fh,$modpod)]} { + close $connected(fh,$modpod) + } + array unset connected *,$modpod + set connected(to) [lreplace $connected(to) $posn $posn] + return 1 + } + proc get {args} { + set argd [punk::args::get_dict { + -from -default "" -help "path to pod" + *values -min 1 -max 1 + filename + } $args] + set frompod [dict get $argd opts -from] + set filename [dict get $argd values filename] + + variable connected + #//review + set modpod [::modpod::system::connect_if_not $frompod] + set fh $connected(fh,$modpod) + if {$connected(type,$modpod) eq "unwrapped"} { + #for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder + if {[string range $filename 0 0 eq "/"]} { + #absolute path (?) + set path [file join $connected(location,$modpod) .. [string trim $filename /]] + } else { + #relative path - use #modpod-xxx as base + set path [file join $connected(location,$modpod) $filename] + } + set fd [open $path r] + #utf-8? + #fconfigure $fd -encoding iso8859-1 -translation binary + return [list ok [lindex [list [read $fd] [close $fd]] 0]] + } else { + #read from vfs + puts stderr "get $filename from wrapped pod '$frompod' not implemented" + } + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace modpod ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval modpod::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace modpod::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + proc is_valid_tm_version {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionparts $versionparts]]} { + return 1 + } else { + return 0 + } + } + + #zipfile is a pure zip at this point - ie no script/exe header + proc make_zip_modpod {args} { + set argd [punk::args::get_dict { + -offsettype -default "archive" -choices {archive file} -help "Whether zip offsets are relative to start of file or start of zip-data within the file. + 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, + but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) + info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. + -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" + *values -min 2 -max 2 + zipfile -type path -minlen 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" + outfile -type path -minlen 1 -help "path to output file. Name should be of the form packagename-version.tm" + } $args] + set zipfile [dict get $argd values zipfile] + set outfile [dict get $argd values outfile] + set opt_offsettype [dict get $argd opts -offsettype] + + + set mount_stub [string map [list %offsettype% $opt_offsettype] { + #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. + #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. + #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% + if {[catch {file normalize [info script]} modfile]} { + error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" + } + if {$modfile eq "" || ![file exists $modfile]} { + error "modpod zip stub error. Unable to determine module path" + } + set moddir [file dirname $modfile] + set mod_and_ver [file rootname [file tail $modfile]] + lassign [split $mod_and_ver -] moduletail version + if {[file exists $moddir/#modpod-$mod_and_ver]} { + source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm + } else { + #determine module namespace so we can mount appropriately + proc intersect {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return {}} + if {[llength $B] > [llength $A]} { + set res $A + set A $B + set B $res + } + set res {} + foreach x $A {set ($x) {}} + foreach x $B { + if {[info exists ($x)]} { + lappend res $x + } + } + return $res + } + set lcase_tmfile_segments [string tolower [file split $moddir]] + set lcase_modulepaths [string tolower [tcl::tm::list]] + foreach lc_mpath $lcase_modulepaths { + set mpath_segments [file split $lc_mpath] + if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { + set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail + break + } + } + if {[llength $tail_segments]} { + set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require + set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver + } else { + set fullpackage $moduletail + set mount_at #modpod/#mounted-modpod-$mod_and_ver + } + + if {[info commands tcl::zipfs::mount] ne ""} { + #argument order changed to be consistent with vfs::zip::Mount etc + #early versions: zipfs::Mount mountpoint zipname + #since 2023-09: zipfs::Mount zipname mountpoint + #don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) + #This is presumably related to // being interpreted as a network path + set mountpoints [dict keys [tcl::zipfs::mount]] + if {"//zipfs:/$mount_at" ni $mountpoints} { + #despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it + if {[catch { + #tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) + #puts "tcl::zipfs::mount $modfile $mount_at" + tcl::zipfs::mount $modfile $mount_at + } errM]} { + #try old api + if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { + puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" + puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" + } + } + if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" + #tcl::zipfs::unmount //zipfs:/$mount_at + error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" + } + } + # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form + source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm + } else { + #fallback to slower vfs::zip + #NB. We don't create the intermediate dirs - but the mount still works + if {![file exists $moddir/$mount_at]} { + if {[catch {package require vfs::zip} errM]} { + set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" + append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." + append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" + error $msg + } else { + set fd [vfs::zip::Mount $modfile $moddir/$mount_at] + if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + vfs::zip::Unmount $fd $moddir/$mount_at + error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" + } + } + } + source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm + } + } + #zipped data follows + }] + #todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? + append mount_stub \x1A + modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype + + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace modpod::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval modpod::system { + #*** !doctools + #[subsection {Namespace modpod::system}] + #[para] Internal functions that are not part of the API + + #deflate,store only supported + + #zipfile here is plain zip - no script/exe prefix part. + proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { + set inzip [open $zipfile r] + fconfigure $inzip -encoding iso8859-1 -translation binary + set out [open $outfile w+] + fconfigure $out -encoding iso8859-1 -translation binary + puts -nonewline $out $mount_stub + set stuboffset [tell $out] + lappend report "stub size: $stuboffset" + fcopy $inzip $out + close $inzip + + set size [tell $out] + lappend report "tmfile : [file tail $outfile]" + lappend report "output size : $size" + lappend report "offsettype : $offsettype" + + if {$offsettype eq "file"} { + #make zip offsets relative to start of whole file including prepended script. + #same offset structure as Tcl's 'zipfs mkimg' as at 2024-10 + #not editable by 7z,nanazip,peazip + + #we aren't adding any new files/folders so we can edit the offsets in place + + #Now seek in $out to find the end of directory signature: + #The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text + if {$size < 65559} { + set tailsearch_start 0 + } else { + set tailsearch_start [expr {$size - 65559}] + } + seek $out $tailsearch_start + set data [read $out] + #EOCD - End of Central Directory record + #PK\5\6 + set start_of_end [string last "\x50\x4b\x05\x06" $data] + #set start_of_end [expr {$start_of_end + $seek}] + #incr start_of_end $seek + set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] + + lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" + + seek $out $filerelative_eocd_posn + set end_of_ctrl_dir [read $out] + binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + + lappend report "End of central directory: [array get eocd]" + seek $out [expr {$filerelative_eocd_posn+16}] + + #adjust offset of start of central directory by the length of our sfx stub + puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] + flush $out + + seek $out $filerelative_eocd_posn + set end_of_ctrl_dir [read $out] + binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + + # 0x06054b50 - end of central dir signature + puts stderr "$end_of_ctrl_dir" + puts stderr "comment_len: $eocd(comment_len)" + puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" + lappend report "New dir offset: $eocd(diroffset)" + lappend report "Adjusting $eocd(totalnum) zip file items." + catch { + punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies + } + + seek $out $eocd(diroffset) + for {set i 0} {$i <$eocd(totalnum)} {incr i} { + set current_file [tell $out] + set fileheader [read $out 46] + puts -------------- + puts [ansistring VIEW -lf 1 $fileheader] + puts -------------- + #binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + # x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + + binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + set ::last_header $fileheader + + puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" + puts "ver: $x(version)" + puts "method: $x(method)" + + #PK\1\2 + #33639248 dec = 0x02014b50 - central directory file header signature + if { $x(sig) != 33639248 } { + error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" + } + + foreach size $x(lengths) var {filename extrafield comment} { + if { $size > 0 } { + set x($var) [read $out $size] + } else { + set x($var) "" + } + } + set next_file [tell $out] + lappend report "file $i: $x(offset) $x(sizes) $x(filename)" + + seek $out [expr {$current_file+42}] + puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] + + #verify: + flush $out + seek $out $current_file + set fileheader [read $out 46] + lappend report "old $x(offset) + $stuboffset" + binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + lappend report "new $x(offset)" + + seek $out $next_file + } + } + + close $out + #pdict/showdict reuire punk & textlib - ie lots of dependencies + #don't fall over just because of that + catch { + punk::lib::showdict -roottype list -chan stderr $report + } + #puts [join $report \n] + return + } + + proc connect_if_not {{podpath ""}} { + upvar ::modpod::connected connected + set podpath [::modpod::system::normalize $podpath] + set docon 0 + if {![llength $connected(to)]} { + if {![string length $podpath]} { + error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" + } else { + set docon 1 + } + } else { + if {![string length $podpath]} { + set podpath [lindex $connected(to) end] + puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" + } else { + if {$podpath ni $connected(to)} { + set docon 1 + } + } + } + if {$docon} { + if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { + error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" + } else { + return $podpath + } + } + #we were already connected + return $podpath + } + + proc myversion {} { + upvar ::modpod::connected connected + set script [info script] + if {![string length $script]} { + error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" + } + set fname [file tail [file rootname [file normalize $script]]] + set scriptdir [file dirname $script] + + if {![string match "#modpod-*" $fname]} { + lassign [lrange [split $fname -] end-1 end] _pkgname version + } else { + lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version + if {![string length $version]} { + #try again on the name of the containing folder + lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version + #todo - proper walk up the directory tree + if {![string length $version]} { + #try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) + lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version + } + } + } + + #tarjar::Log debug "'myversion' determined version for [info script]: $version" + return $version + } + + proc myname {} { + upvar ::modpod::connected connected + set script [info script] + if {![string length $script]} { + error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" + } + return $connected(fullpackage,$script) + } + proc myfullname {} { + upvar ::modpod::connected connected + set script [info script] + #set script [::tarjar::normalize $script] + set script [file normalize $script] + if {![string length $script]} { + error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" + } + return $::tarjar::connected(fullpackage,$script) + } + proc normalize {path} { + #newer versions of Tcl don't do tilde sub + + #Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) + # we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. + set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. + set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after + set path [file normalize $path] + #set path [string tolower $path] ;#must do this after file normalize + return [string map [list $matilda ~] $path] ;#get our tildes back. +} +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide modpod [namespace eval modpod { + variable pkg modpod + variable version + set version 0.1.2 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/bootsupport/modules/punk/args-0.1.0.tm b/src/bootsupport/modules/punk/args-0.1.0.tm index c8a6ec84..bd4f70fe 100644 --- a/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/bootsupport/modules/punk/args-0.1.0.tm @@ -268,6 +268,34 @@ tcl::namespace::eval punk::args { #[list_begin definitions] + if {[info commands ::tcl::dict::getdef] eq ""} { + #package require punk::lib + #interp alias "" ::punk::args::Dict_getdef "" ::punk::lib::dict_getdef + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + #todo? -synonym ? (applies to opts only not values) #e.g -background -synonym -bg -default White @@ -339,10 +367,26 @@ tcl::namespace::eval punk::args { } #puts "indent1:[ansistring VIEW $lastindent]" set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } foreach rawline $linelist { set recordsofar [tcl::string::cat $linebuild $rawline] #ansi colours can stop info complete from working (contain square brackets) - if {![tcl::info::complete [punk::ansi::ansistrip $recordsofar]]} { + #review - when exactly are ansi codes allowed/expected in argspecs. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { #append linebuild [string trimleft $rawline] \n if {$in_record} { if {[tcl::string::length $lastindent]} { @@ -602,7 +646,7 @@ tcl::namespace::eval punk::args { } } } - -default - -solo - -range - -choices - -choiceprefix - -choicelabels - -choiceprefix - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE { + -default - -solo - -range - -choices - -choiceprefix - -choicelabels - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE { #review -solo 1 vs -type none ? tcl::dict::set spec_merged $spec $specval } @@ -711,8 +755,8 @@ tcl::namespace::eval punk::args { if {![catch {package require textblock}]} { if {[catch { append errmsg \n - set procname [punk::lib::dict_getdef $spec_dict proc_info -name ""] - set prochelp [punk::lib::dict_getdef $spec_dict proc_info -help ""] + set procname [::punk::args::Dict_getdef $spec_dict proc_info -name ""] + set prochelp [::punk::args::Dict_getdef $spec_dict proc_info -help ""] #set t [textblock::class::table new [a+ web-yellow]Usage[a]] set t [textblock::class::table new [a+ brightyellow]Usage[a]] @@ -787,7 +831,7 @@ tcl::namespace::eval punk::args { } else { set default "" } - set help [punk::lib::dict_getdef $arginfo -help ""] + set help [::punk::args::Dict_getdef $arginfo -help ""] if {[dict exists $arginfo -choices]} { if {$help ne ""} {append help \n} if {[dict get $arginfo -nocase]} { @@ -801,7 +845,7 @@ tcl::namespace::eval punk::args { set prefixmsg "" } append help "Choices$prefixmsg$casemsg" - if {[catch {package require punk::trie}]} { + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { append help "\n " [join [dict get $arginfo -choices] "\n "] } else { if {[catch { @@ -825,7 +869,7 @@ tcl::namespace::eval punk::args { } } } - if {[punk::lib::dict_getdef $arginfo -multiple 0]} { + if {[::punk::args::Dict_getdef $arginfo -multiple 0]} { set multiple $greencheck } else { set multiple "" @@ -842,7 +886,7 @@ tcl::namespace::eval punk::args { } else { set default "" } - set help [punk::lib::dict_getdef $arginfo -help ""] + set help [::punk::args::Dict_getdef $arginfo -help ""] if {[dict exists $arginfo -choices]} { if {$help ne ""} {append help \n} if {[dict get $arginfo -nocase]} { @@ -856,7 +900,7 @@ tcl::namespace::eval punk::args { set prefixmsg "" } append help "Choices$prefixmsg$casemsg" - if {[catch {package require punk::trie}]} { + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { append help "\n " [join [dict get $arginfo -choices] "\n "] } else { if {[catch { @@ -880,7 +924,7 @@ tcl::namespace::eval punk::args { } } } - if {[punk::lib::dict_getdef $arginfo -multiple 0]} { + if {[punk::args::Dict_getdef $arginfo -multiple 0]} { set multiple $greencheck } else { set multiple "" @@ -1261,10 +1305,10 @@ tcl::namespace::eval punk::args { # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" #} #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punk::lib::ldiff $opt_required $flagsreceived]]]} { + if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present in full-length form" $argspecs } - if {[llength [set missing [punk::lib::ldiff $val_required $valnames_received]]]} { + if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs } @@ -1396,14 +1440,25 @@ tcl::namespace::eval punk::args { package require ansi } int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive if {[tcl::dict::exists $thisarg -range]} { lassign [tcl::dict::get $thisarg -range] low high foreach e $vlist e_check $vlist_check { if {![tcl::string::is integer -strict $e_check]} { arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs $argname } - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer between $low and $high. Received: '$e'" $argspecs $argname + if {$low eq ""} { + if {$e_check < $low} { + arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs $argname + } + } elseif {$high eq ""} { + if {$e_check > $high} { + arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs $argname + } + } else { + if {$e_check < $low || $e_check > $high} { + arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs $argname + } } } } else { @@ -1426,6 +1481,7 @@ tcl::namespace::eval punk::args { switch -- $checkopt { -range { #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high lassign $checkval low high if {$e_check < $low || $e_check > $high} { arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs $argname @@ -1493,7 +1549,8 @@ tcl::namespace::eval punk::args { existingfile - existingdirectory { foreach e $vlist e_check $vlist_check { - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*?<>\;]} $e_check])} { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { #what about special file names e.g on windows NUL ? arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs $argname } diff --git a/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm b/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm index 2926b237..eacc6619 100644 --- a/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm @@ -505,11 +505,13 @@ namespace eval punk::cap::handlers::templates { set subpathlist [split $tailats +] if {[dict exists $refinfo sourceinfo projectbase]} { #some template pathtypes refer to the projectroot from the template - not the cwd - set projectroot [dict get $refinfo sourceinfo projectbase] + set ref_projectroot [dict get $refinfo sourceinfo projectbase] + } else { + set ref_projectroot $projectroot } - if {$projectroot ne ""} { - set layoutroot [file join $projectroot src/project_layouts] + if {$ref_projectroot ne ""} { + set layoutroot [file join $ref_projectroot src/project_layouts] set layoutfolder [file join $layoutroot {*}$subpathlist] if {[file isdirectory $layoutfolder]} { #todo - check if layoutname already in layoutdict append .ref path to list of refs that linked to this layout? diff --git a/src/bootsupport/modules/punk/mix/base-0.1.tm b/src/bootsupport/modules/punk/mix/base-0.1.tm index dfdc71f9..d2d40bba 100644 --- a/src/bootsupport/modules/punk/mix/base-0.1.tm +++ b/src/bootsupport/modules/punk/mix/base-0.1.tm @@ -468,16 +468,15 @@ namespace eval punk::mix::base { #adler32 via file-slurp proc cksum_adler32_file {filename} { - package require zlib; #should be builtin anyway + #2024 - zlib should be builtin - otherwise fallback to trf + zlibtcl? set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] #set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names zlib adler32 $data } #zlib crc via file-slurp proc cksum_crc_file {filename} { - package require zlib set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] - zlib crc $data + zlib crc32 $data } proc cksum_md5_data {data} { diff --git a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index 6a1252f0..d9d36291 100644 --- a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -687,27 +687,52 @@ namespace eval punk::mix::cli { package require punk::zip set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate) - if 0 { - #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise - punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile * - #punk::zip::mkzip stores permissions - (unix style) which confuses zipfs when reading - it misidentifies dirs as files + set zipmechanism "punk::zip" ;#todo - get choice of mechanism from config + + switch -- $zipmechanism { + "punk::zip" { + #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise + punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile * + } + "zipfs" { + if {[llength [info commands zipfs]]} { + #'zipfs mkzip' does we need in this case + #unfortunately it's not available in all Tclsh versions we might be running.. + # + #sidenote: + # as at 2024-10 - zipfs mkimg seems to create an apparently working zip - but on windows not updatable with 'zip -A' or 7z etc + #This is because offsets are file relative vs archive relative + #(pkzip & info-zip seem to prefer file-relative ie offsets that have been adjusted after cat headerfile zipfile > somekit + #this isn't an issue for 'mkzip' here though as we don't yet have a headerfile so offset file vs archive are the same. + + set wd [pwd] + cd $buildfolder + puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version" + zipfs mkzip $zipfile #modpod-$basename-$module_build_version + cd $wd + } else { + #TODO - review punk::zip::mkzip and/or external zip to provide a fallback? + set had_error 1 + lappend notes "zipfs_unavailable" + puts stderr "WARNING: zipfs unavailable can't build $modulefile" + } + } + default { + set had_error 1 + lappend notes "unrecognized_zipmechanism" + puts stderr "WARNING: no such zipmechanism '$zipmechanism' can't build $modulefile" + } } - #zipfs mkzip does exactly what we need anyway in this case - #unfortunately it's not available in all Tclsh versions we might be running.. - if {[llength [info commands zipfs]]} { - set wd [pwd] - cd $buildfolder - puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version" - zipfs mkzip $zipfile #modpod-$basename-$module_build_version - cd $wd + if {[catch {package require modpod} errM]} { + set had_error 1 + lappend notes "modpod_unavailable" + puts stderr "WARNING: modpod package unavailable can't build $modulefile" + } + + if {!$had_error} { package require modpod modpod::lib::make_zip_modpod $zipfile $modulefile - } else { - #TODO - review punk::zip::mkzip and/or external zip to provide a fallback? - set had_error 1 - lappend notes "zipfs_unavailable" - puts stderr "WARNING: zipfs unavailable can't build $modulefile" } diff --git a/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm index 401ddb72..26bca4d5 100644 --- a/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm @@ -22,7 +22,8 @@ package require punk::args #sort of a circular dependency when commandset loaded by punk::mix::cli - that's ok, but this could theoretically be loaded by another cli and with another base package require punk::mix package require punk::mix::base - +package require punk::lib +package require textblock # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -41,8 +42,10 @@ namespace eval punk::mix::commandset::layout { return [join $allfiles \n] } proc templatefiles {layout} { - set templatefiles [lib::layout_scan_for_template_files $layout] - return [join $templatefiles \n] + set templatefiles_and_tags [lib::layout_scan_for_template_files $layout] + set flatlist [punk::lib::lmapflat v $templatefiles_and_tags {lrange $v 0 end}] + #return [join $templatefiles \n] + textblock::list_as_table -header {"File with tags found" "Tags"} -columns 2 $flatlist } proc templatefiles.relative {layout} { @@ -56,12 +59,14 @@ namespace eval punk::mix::commandset::layout { set stripprefix [file normalize $layoutfolder] - set templatefiles [lib::layout_scan_for_template_files $layout] - set tails [list] - foreach templatefullpath $templatefiles { - lappend tails [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] + set templatefiles_and_tags [lib::layout_scan_for_template_files $layout] + set flatlist [list] + foreach entry $templatefiles_and_tags { + lassign $entry templatefullpath tags + lappend flatlist [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] $tags } - return [join $tails \n] + #return [join $tails \n] + textblock::list_as_table -header {"File with tags found" "Tags"} -columns 2 $flatlist } #layout collection functions - to be imported with punk::overlay::import_commandset separately @@ -110,28 +115,16 @@ namespace eval punk::mix::commandset::layout { } set title(path) "Path" - set widest(path) [tcl::mathfunc::max {*}[lmap v [concat [list $title(path)] $paths] {punk::strlen $v}]] - set col(path) [string repeat " " $widest(path)] set title(pathtype) "[a+ green]Path Type[a]" - set widest(pathtype) [tcl::mathfunc::max {*}[lmap v [concat [list $title(pathtype)] $pathtypes] {punk::strlen $v}]] - set col(pathtype) [string repeat " " $widest(pathtype)] set title(name) "Layout Name" - set widest(name) [tcl::mathfunc::max {*}[lmap v [concat [list $title(name)] $names] {punk::strlen $v}]] - set col(name) [string repeat " " $widest(name)] - - set vsep " | " - set vsep_w [string length $vsep] ;#unicode? - set tablewidth [expr {$widest(name) + $vsep_w + $widest(pathtype) + $vsep_w + $widest(path)}] - set table "" - append table [string repeat - $tablewidth] \n - append table "[textblock::join -- [overtype::left $col(name) $title(name)] $vsep [overtype::left $col(pathtype) $title(pathtype)] $vsep [overtype::left $col(path) $title(path)]]" \n - append table [string repeat - $tablewidth] \n + set data [list] foreach n $names pt $pathtypes p $paths { - append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n + lappend data $n $pt $p } + set table [textblock::list_as_table -columns 3 -header [list $title(name) $title(pathtype) $title(path)] $data] return $table } @@ -156,29 +149,16 @@ namespace eval punk::mix::commandset::layout { lappend pathtypes [dict get $tinfo sourceinfo pathtype] } - set title(path) "Path" - set widest(path) [tcl::mathfunc::max {*}[lmap v [concat [list $title(path)] $paths] {punk::strlen $v}]] - set col(path) [string repeat " " $widest(path)] - - set title(pathtype) "[a+ green]Path Type[a]" - set widest(pathtype) [tcl::mathfunc::max {*}[lmap v [concat [list $title(pathtype)] $pathtypes] {punk::strlen $v}]] - set col(pathtype) [string repeat " " $widest(pathtype)] - set title(name) "Layout Name" - set widest(name) [tcl::mathfunc::max {*}[lmap v [concat [list $title(name)] $names] {punk::strlen $v}]] - set col(name) [string repeat " " $widest(name)] - - set vsep " | " - set vsep_w [string length $vsep] ;#unicode? - set tablewidth [expr {$widest(name) + $vsep_w + $widest(pathtype) + $vsep_w + $widest(path)}] - set table "" - append table [string repeat - $tablewidth] \n - append table "[textblock::join -- [overtype::left $col(name) $title(name)] $vsep [overtype::left $col(pathtype) $title(pathtype)] $vsep [overtype::left $col(path) $title(path)]]" \n - append table [string repeat - $tablewidth] \n + set title(pathtype) "[a+ green]Path Type[a]" + set title(path) "Path" + set data [list] foreach n $names pt $pathtypes p $paths { - append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n + #append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n + lappend data $n $pt $p } + set table [textblock::list_as_table -columns 3 -header [list $title(name) $title(pathtype) $title(path)] $data] return $table } @@ -243,7 +223,7 @@ namespace eval punk::mix::commandset::layout { #todo - get standard tags from somewhere set tagnames [list project] foreach tn $tagnames { - lappend tags [string cat % $tn %] + lappend tags [string cat % $tn %] ;#make sure actual tag literal doesn't appear in this source file } } set file_list [list] @@ -252,11 +232,15 @@ namespace eval punk::mix::commandset::layout { fconfigure $fd -translation binary set data [read $fd] close $fd - foreach tag $tags { + set found_tags [list] + foreach tag $tags tn $tagnames { if {[string match "*$tag*" $data]} { - lappend file_list $path + lappend found_tags $tn } } + if {[llength $found_tags]} { + lappend file_list [list $path $found_tags] + } } return $file_list diff --git a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index 80cab2a7..27ec8503 100644 --- a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -395,19 +395,30 @@ namespace eval punk::mix::commandset::project { set templatefiles [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] set stripprefix [file normalize $layout_path] - set tagmap [list [lib::template_tag project] $projectname] + #set tagmap [list [lib::template_tag project] $projectname] + #todo - get from somewhere + set alltag_substitutions [list project $projectname] + if {[llength $templatefiles]} { puts stdout "Filling template file placeholders with the following tag map:" - foreach {placeholder value} $tagmap { + foreach {placeholder value} $alltag_substitutions { puts stdout " $placeholder -> $value" } } - foreach templatefullpath $templatefiles { + foreach templatefullpath_and_tags $templatefiles { + lassign $templatefullpath_and_tags templatefullpath tags_present + set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] set fpath [file join $projectdir $templatetail] if {[file exists $fpath]} { set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set tagmap [list] + dict for {t v} $alltag_substitutions { + if {$t in $tags_present} { + lappend tagmap [lib::template_tag $t] $v + } + } set data2 [string map $tagmap $data] if {$data2 ne $data} { puts stdout "updated template file: $fpath" diff --git a/src/bootsupport/modules/punk/mix/templates/modules/modulename_buildversion.txt b/src/bootsupport/modules/punk/mix/templates/modules/modulename_buildversion.txt index 6266c016..3b852c99 100644 --- a/src/bootsupport/modules/punk/mix/templates/modules/modulename_buildversion.txt +++ b/src/bootsupport/modules/punk/mix/templates/modules/modulename_buildversion.txt @@ -1,3 +1,3 @@ %Major.Minor.Level% -#First line must be a semantic version number +#First line must be a tcl package version number #all other lines are ignored. diff --git a/src/bootsupport/modules/punk/trie-0.1.0.tm b/src/bootsupport/modules/punk/trie-0.1.0.tm new file mode 100644 index 00000000..6f7f9d14 --- /dev/null +++ b/src/bootsupport/modules/punk/trie-0.1.0.tm @@ -0,0 +1,600 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) CMcC 2010 +# +# @@ Meta Begin +# Application punk::trie 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::trie 0 0.1.0] +#[copyright "2010"] +#[titledesc {punk::trie API}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk::trie}] [comment {-- Description at end of page heading --}] +#[require punk::trie] +#[keywords module datastructure trie] +#[description] tcl trie implementation courtesy of CmcC (tcl wiki) +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::trie +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::trie +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::trie::class { + #*** !doctools + #[subsection {Namespace punk::trie::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::trie { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + #variable xyz + proc Dolog {lvl txt} { + #return "$lvl -- $txt" + #logger calls this in such a way that a straight uplevel can get us the vars/commands in messages substituted + set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] punk::trie '[uplevel [list subst $txt]]'" + puts stderr $msg + } + package require logger + logger::initNamespace ::punk::trie + foreach lvl [logger::levels] { + interp alias {} ::punk::trie::Log_$lvl {} ::punk::trie::Dolog $lvl + log::logproc $lvl ::punk::trie::Log_$lvl + } + #namespace path ::punk::trie::log + + #[para] class definitions + if {[tcl::info::commands [tcl::namespace::current]::trieclass] eq ""} { + #*** !doctools + #[list_begin enumerated] + oo::class create [tcl::namespace::current]::trieclass { + variable trie id + + method matches {t what} { + #*** !doctools + #[call class::trieclass [method matches] [arg t] [arg what]] + #[para] search for longest prefix, return matching prefix, element and suffix + + set matches {} + set wlen [string length $what] + foreach k [lsort -decreasing -dictionary [dict keys $t]] { + set klen [string length $k] + set match "" + for {set i 0} {$i < $klen + && $i < $wlen + && [string index $k $i] eq [string index $what $i] + } {incr i} { + append match [string index $k $i] + } + if {$match ne ""} { + lappend matches $match $k + } + } + #Debug.trie {matches: $what -> $matches} + ::punk::trie::log::debug {matches: $what -> $matches} + + if {[dict size $matches]} { + # find the longest matching prefix + set match [lindex [lsort -dictionary [dict keys $matches]] end] + set mel [dict get $matches $match] + set suffix [string range $what [string length $match] end] + + return [list $match $mel $suffix] + } else { + return {} ;# no matches + } + } + + # return next unique id if there's no proffered value + method id {value} { + if {$value} { + return $value + } else { + return [incr id] + } + } + + # insert an element with a given optional value into trie + # along path given by $args (no need to specify) + method insert {what {value 0} args} { + if {[llength $args]} { + set t [dict get $trie {*}$args] + } else { + set t $trie + } + + if {[dict exists $t $what]} { + #Debug.trie {$what is an exact match on path ($args $what)} + ::punk::trie::log::debug {$what is an exact match on path ($args $what)} + if {[catch {dict size [dict get $trie {*}$args $what]} size]} { + # the match is a leaf - we're done + } else { + # the match is a dict - we have to add a null + dict set trie {*}$args $what "" [my id $value] + } + + return ;# exact match - no change + } + + # search for longest prefix + set match [my matches $t $what] + + if {![llength $match]} { + ;# no matching prefix - new element + #Debug.trie {no matching prefix of '$what' in $t - add it on path ($args $what)} + ::punk::trie::log::debug {no matching prefix of '$what' in $t add it on path ($args $what)} + dict set trie {*}$args $what [my id $value] + return + } + + lassign $match match mel suffix ;# prefix, element of match, suffix + + if {$match ne $mel} { + # the matching element shares a prefix, but has a variant suffix + # it must be split + #Debug.trie {splitting '$mel' along '$match'} + ::punk::trie::log::debug {splitting '$mel' along '$match'} + + set melC [dict get $t $mel] + dict unset trie {*}$args $mel + dict set trie {*}$args $match [string range $mel [string length $match] end] $melC + } + + if {[catch {dict size [dict get $trie {*}$args $match]} size]} { + # the match is a leaf - must be split + if {$match eq $mel} { + # the matching element shares a prefix, but has a variant suffix + # it must be split + #Debug.trie {splitting '$mel' along '$match'} + ::punk::trie::log::debug {splitting '$mel' along '$match'} + set melC [dict get $t $mel] + dict unset trie {*}$args $mel + dict set trie {*}$args $match "" $melC + } + #Debug.trie {'$mel' is the longest prefix '$match' but was a leaf - insert '$suffix'} + ::punk::trie::log::debug {'$mel' is the longest prefix '$match' but was a leaf - insert '$suffix'} + set melid [dict get $t $mel] + dict set trie {*}$args $match $suffix [my id $value] + } else { + # it's a dict - keep searching + #Debug.trie {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} + ::punk::trie::log::debug {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} + my insert $suffix $value {*}$args $match + } + return + } + + # find a path matching an element $what + # if the element's not found, return the nearest path + method find_path {what args} { + if {[llength $args]} { + set t [dict get $trie {*}$args] + } else { + set t $trie + } + + if {[dict exists $t $what]} { + #Debug.trie {$what is an exact match on path ($args $what)} + return [list {*}$args $what] ;# exact match - no change + } + + # search for longest prefix + set match [my matches $t $what] + + if {![llength $match]} { + return $args + } + + lassign $match match mel suffix ;# prefix, element of match, suffix + + if {$match ne $mel} { + # the matching element shares a prefix, but has a variant suffix + # no match + return $args + } + + if {[catch {dict size [dict get $trie {*}$args $match]} size] || $size == 0} { + # got to a non-matching leaf - no match + return $args + } else { + # it's a dict - keep searching + #Debug.trie {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} + return [my find_path $suffix {*}$args $match] + } + } + + # given a trie, which may have been modified by deletion, + # optimize it by removing empty nodes and coalescing singleton nodes + method optimize {args} { + if {[llength $args]} { + set t [dict get $trie {*}$args] + } else { + set t $trie + } + + if {[catch {dict size $t} size]} { + #Debug.trie {optimize leaf '$t' along '$args'} + ::punk::trie::log::debug {optimize leaf '$t' along '$args'} + # leaf - leave it + } else { + switch -- $size { + 0 { + #Debug.trie {optimize empty dict ($t) along '$args'} + ::punk::trie::log::debug {optimize empty dict ($t) along '$args'} + if {[llength $args]} { + dict unset trie {*}$args + } + } + 1 { + #Debug.trie {optimize singleton dict ($t) along '$args'} + ::punk::trie::log::debug {optimize singleton dict ($t) along '$args'} + lassign $t k v + if {[llength $args]} { + dict unset trie {*}$args + } + append args $k + if {[llength $v]} { + dict set trie {*}$args $v + } + my optimize {*}$args + } + default { + #Debug.trie {optimize dict ($t) along '$args'} + ::punk::trie::log::debug {optimize dict ($t) along '$args'} + dict for {k v} $t { + my optimize {*}$args $k + } + } + } + } + } + + # delete element $what from trie + method delete {what} { + set path [my find_path $what] + if {[join $path ""] eq $what} { + #Debug.trie {del '$what' along ($path) was [dict get $trie {*}$path]} + if {[catch {dict size [dict get $trie {*}$path]} size]} { + # got to a matching leaf - delete it + dict unset trie {*}$path + set path [lrange $path 0 end-1] + } else { + dict unset trie {*}$path "" + } + + my optimize ;# remove empty and singleton elements + } else { + # nothing to delete, guess we're done + } + } + + # find the value of element $what in trie, + # error if not found + method find_or_error {what} { + set path [my find_path $what] + if {[join $path ""] eq $what} { + if {[catch {dict size [dict get $trie {*}$path]} size]} { + # got to a matching leaf - done + return [dict get $trie {*}$path] + } else { + #JMN - what could be an exact match for a path, but not be in the trie itself + if {[dict exists $trie {*}$path ""]} { + return [dict get $trie {*}$path ""] + } else { + ::punk::trie::log::debug {'$what' matches a path but is not a leaf} + error "'$what' not found" + } + } + } else { + error "'$what' not found" + } + } + #JMN - renamed original find to find_or_error + #prefer not to catch on result - but test for -1 + method find {what} { + set path [my find_path $what] + if {[join $path ""] eq $what} { + #presumably we use catch and dict size to avoid llength shimmering large inner dicts to list rep + if {[catch {dict size [dict get $trie {*}$path]} size]} { + # got to a matching leaf - done + return [dict get $trie {*}$path] + } else { + #JMN - what could be an exact match for a path, but not be in the trie itself + if {[dict exists $trie {*}$path ""]} { + return [dict get $trie {*}$path ""] + } else { + ::punk::trie::log::debug {'$what' matches a path but is not a leaf} + return -1 + } + } + } else { + return -1 + } + } + + # dump the trie as a string + method dump {} { + return $trie + } + + # return a string rep of the trie sorted in dict order + method order {{t {}}} { + if {![llength $t]} { + set t $trie + } elseif {[llength $t] == 1} { + return $t + } + set acc {} + + foreach key [lsort -dictionary [dict keys $t]] { + lappend acc $key [my order [dict get $t $key]] + } + return $acc + } + + # return the trie as a dict of names with values + method flatten {{t {}} {prefix ""}} { + if {![llength $t]} { + set t $trie + } elseif {[llength $t] == 1} { + return [list $prefix $t] + } + + set acc {} + + foreach key [dict keys $t] { + lappend acc {*}[my flatten [dict get $t $key] $prefix$key] + } + return $acc + } + + #shortest possible string to identify an element in the trie using the same principle as tcl::prefix::match + #ie if a stored word is a prefix of any other words - it must be fully specified to identify itself. + #JMN - REVIEW - better algorithms? + #caller having retained all members can avoid flatten call + #by selecting a single 'which' known not to be in the trie (or empty string) - all idents can be returned. + #when all 'which' members are in the tree - scanning stops when they're all found + # - and a dict containing result and scanned keys is returned + # - result contains a dict with keys for each which member + # - scanned contains a dict of all words longer than our shortest which - (and a subset of words the same length) + method shortest_idents {which {allmembers {}}} { + set t $trie + if {![llength $allmembers]} { + set members [dict keys [my flatten]] + } else { + set members $allmembers + } + set len_members [lmap m $members {list [string length $m] $m}] + set longestfirst [lsort -index 0 -integer -decreasing $len_members] + set longestfirst [lmap v $longestfirst {lindex $v 1}] + set taken [dict create] + set scanned [dict create] + set result [dict create] ;#words in our which list - if found + foreach w $longestfirst { + set path [my find_path $w] + if {[dict exists $taken $w]} { + #whole word - no unique prefix + dict set scanned $w $w + if {$w in $which} { + #puts stderr "$w -> $w" + dict set result $w $w + if {[dict size $result] == [llength $which]} { + return [dict create result $result scanned $scanned] + } + } + continue + } + set acc "" + foreach p [lrange $path 0 end-1] { + dict set taken [append acc $p] 1 ;#no need to test first - just set even though may already be present + } + append acc [string index [lindex $path end] 0] + dict set scanned $w $acc ;#sorted by length - so no other can have this prefix - and no longer necessary + if {$w in $which} { + #puts stderr "$w -> $acc" + dict set result $w $acc + if {[dict size $result] == [llength $which]} { + return [dict create result $result scanned $scanned] + } + } + } + return [dict create result $result scanned $scanned] + } + + # overwrite the trie + method set {t} { + set trie $t + } + + constructor {args} { + set trie {} + set id 0 + foreach a $args { + my insert $a + } + } + } + + set testlist [list blah x black blacken] + proc test1 {} { + #JMN + #test that find_or_error of a path that isn't stored as a value returns an appropriate error + #(used to report couldn't find dict key "") + set t [punk::trie::trieclass new blah x black blacken] + if {[catch {$t find_or_error bla} errM]} { + puts stderr "should be error indicating 'bla' not found" + puts stderr "err during $t find bla\n$errM" + } + return $t + } + + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + } + + #*** !doctools + #[subsection {Namespace punk::trie}] + #[para] Core API functions for punk::trie + #[list_begin definitions] + + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::trie ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::trie::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::trie::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::trie::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval punk::trie::system { + #*** !doctools + #[subsection {Namespace punk::trie::system}] + #[para] Internal functions that are not part of the API + + + +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::trie [tcl::namespace::eval punk::trie { + variable pkg punk::trie + variable version + set version 0.1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/bootsupport/modules/punk/zip-0.1.0.tm b/src/bootsupport/modules/punk/zip-0.1.0.tm index 628419fa..44af7472 100644 --- a/src/bootsupport/modules/punk/zip-0.1.0.tm +++ b/src/bootsupport/modules/punk/zip-0.1.0.tm @@ -244,14 +244,131 @@ tcl::namespace::eval punk::zip { if {!$excluded} {lappend result $file} } foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { - set subdir [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] - if {[llength $subdir]>0} { - set result [concat $result $dir $subdir] + set subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] + if {[llength $subdir_entries]>0} { + #NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" + #This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash + #Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. + set result [list {*}$result "$dir/" {*}$subdir_entries] } } return $result } + + proc extract_zip_prefix {infile outfile} { + set inzip [open $infile r] + fconfigure $inzip -encoding iso8859-1 -translation binary + if {[file exists $outfile]} { + error "outfile $outfile already exists - please remove first" + } + chan seek $inzip 0 end + set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent + chan seek $inzip 0 start + #only scan last 64k - cover max signature size?? review + if {$insize < 65559} { + set tailsearch_start 0 + } else { + set tailsearch_start [expr {$insize - 65559}] + } + chan seek $inzip $tailsearch_start start + set scan [read $inzip] + #EOCD - End Of Central Directory record + set start_of_end [string last "\x50\x4b\x05\x06" $scan] + puts stdout "==>start_of_end: $start_of_end" + + if {$start_of_end == -1} { + #no zip cdr - consider entire file to be the zip prefix + set baseoffset $insize + } else { + set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] + chan seek $inzip $filerelative_eocd_posn + set cdir_record_plus [read $inzip] ;#can have trailing data + binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + #rule out a false positive from within a nonzip (e.g plain exe) + #There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. + #It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway + #we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros + #todo - just search for Pk\5\6\0\0\0\0 in the first place? //review + if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { + #review - should keep searching? + #for now we assume not a zip + set baseoffset $insize + } else { + #use the central dir size to jump back tko start of central dir + #determine if diroffset is file or archive relative + + set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] + puts stdout "---> [read $inzip 4]" + if {$filerelative_cdir_start > $eocd(diroffset)} { + #easy case - 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier + #though we are assuming zip offsets are not corrupted + set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] + } else { + #hard case - either no prefix - or offsets have been adjusted to be file relative. + #we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers + #we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? + #or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete + + #step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) + #we can't assume they're ordered in any particular way - so we in theory have to look at them all. + set baseoffset "unknown" + chan seek $inzip $filerelative_cdir_start start + #binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + # eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + #load the whole central dir into cdir + + #todo! loop through all cdr file headers - find highest offset? + #tclZipfs.c just looks at first file header in Central Directory + #looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW + + set cdirdata [read $inzip $eocd(dirsize)] + binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ + cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ + cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) + + #since we're in this branch - we assume cdir(relativeoffset) is from the start of the file + chan seek $inzip $cdir(relativeoffset) + #let's at least check that we landed on a local file header.. + set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field + binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ + lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) + #dec2hex 67324752 = 4034B50 = PK\3\4 + puts stdout "1st local file header sig: $lfh(signature)" + if {$lfh(signature) == 67324752} { + #looks like a local file header + #use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) + set baseoffset $cdir(relativeoffset) + } + } + puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" + } + } + puts stdout "baseoffset: $baseoffset" + #expect CDFH PK\1\2 + #above the CDFH - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) + #above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script + + if {![string is integer -strict $baseoffset]} { + error "unable to determine zip baseoffset of file $infile" + } + + if {$baseoffset < $insize} { + set out [open $outfile w] + fconfigure $out -encoding iso8859-1 -translation binary + chan seek $inzip 0 start + chan copy $inzip $out -size $baseoffset + close $out + close $inzip + } else { + close $inzip + file copy $infile $outfile + } + } + + + # Mkzipfile -- # # FIX ME: should handle the current offset for non-seekable channels @@ -367,6 +484,12 @@ tcl::namespace::eval punk::zip { append hdr $utfpath $extra $utfcomment return $hdr } + + #### REVIEW!!! + #JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') + # we probably want offsets to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) + #### + # zip::mkzip -- # # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt @@ -526,6 +649,8 @@ tcl::namespace::eval punk::zip { fcopy $rt $zf close $rt } elseif {$opts(-zipkit)} { + #TODO - update to zipfs ? + #see modpod set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" append zkd "package require vfs::zip\n" append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" @@ -535,6 +660,10 @@ tcl::namespace::eval punk::zip { append zkd \x1A puts -nonewline $zf $zkd } + + #todo - subtract this from the endrec offset.. and any ... ? + set dataStartOffset [tell $zf] ;#the overall file offset of the start of data section //JMN 2024 + set count 0 set cd "" diff --git a/src/bootsupport/modules/punk/zip-0.1.1.tm b/src/bootsupport/modules/punk/zip-0.1.1.tm new file mode 100644 index 00000000..2dc235ed --- /dev/null +++ b/src/bootsupport/modules/punk/zip-0.1.1.tm @@ -0,0 +1,818 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 JMN +# (C) 2009 Path Thoyts +# +# @@ Meta Begin +# Application punk::zip 0.1.1 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::zip 0 0.1.1] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::zip] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::zip +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::zip +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::args}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::zip::class { + #*** !doctools + #[subsection {Namespace punk::zip::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::zip { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::zip}] + #[para] Core API functions for punk::zip + #[list_begin definitions] + + proc Path_a_atorbelow_b {path_a path_b} { + return [expr {[StripPath $path_b $path_a] ne $path_a}] + } + proc Path_a_at_b {path_a path_b} { + return [expr {[StripPath $path_a $path_b] eq "." }] + } + + proc Path_strip_alreadynormalized_prefixdepth {path prefix} { + if {$prefix eq ""} { + return $path + } + set pathparts [file split $path] + set prefixparts [file split $prefix] + if {[llength $prefixparts] >= [llength $pathparts]} { + return "" + } + return [file join \ + {*}[lrange \ + $pathparts \ + [llength $prefixparts] \ + end]] + } + + #StripPath - borrowed from tcllib fileutil + # ::fileutil::stripPath -- + # + # If the specified path references/is a path in prefix (or prefix itself) it + # is made relative to prefix. Otherwise it is left unchanged. + # In the case of it being prefix itself the result is the string '.'. + # + # Arguments: + # prefix prefix to strip from the path. + # path path to modify + # + # Results: + # path The (possibly) modified path. + + if {[string equal $::tcl_platform(platform) windows]} { + # Windows. While paths are stored with letter-case preserved al + # comparisons have to be done case-insensitive. For reference see + # SF Tcllib Bug 2499641. + + proc StripPath {prefix path} { + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set prefix [file split $prefix] + set npath [file split $path] + + if {[string equal -nocase $prefix $npath]} { + return "." + } + + if {[string match -nocase "${prefix} *" $npath]} { + set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] + } + return $path + } + } else { + proc StripPath {prefix path} { + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set prefix [file split $prefix] + set npath [file split $path] + + if {[string equal $prefix $npath]} { + return "." + } + + if {[string match "${prefix} *" $npath]} { + set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] + } + return $path + } + } + + proc Timet_to_dos {time_t} { + #*** !doctools + #[call [fun Timet_to_dos] [arg time_t]] + #[para] convert a unix timestamp into a DOS timestamp for ZIP times. + #[example { + # DOS timestamps are 32 bits split into bit regions as follows: + # 24 16 8 0 + # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ + # |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| + # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ + #}] + set s [clock format $time_t -format {%Y %m %e %k %M %S}] + scan $s {%d %d %d %d %d %d} year month day hour min sec + expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) + | ($hour << 11) | ($min << 5) | ($sec >> 1)} + } + + proc walk {args} { + #*** !doctools + #[call [fun walk] [arg ?options?] [arg base]] + #[para] Walk a directory tree rooted at base + #[para] the -excludes list can be a set of glob expressions to match against files and avoid + #[para] e.g + #[example { + # punk::zip::walk -exclude {CVS/* *~.#*} library + #}] + + set argd [punk::args::get_dict { + *proc -name punk::zip::walk + -excludes -default "" -help "list of glob expressions to match against files and exclude" + -subpath -default "" + *values -min 1 -max -1 + base + fileglobs -default {*} -multiple 1 + } $args] + set base [dict get $argd values base] + set fileglobs [dict get $argd values fileglobs] + set subpath [dict get $argd opts -subpath] + set excludes [dict get $argd opts -excludes] + + + set imatch [list] + foreach fg $fileglobs { + lappend imatch [file join $subpath $fg] + } + + set result {} + #set imatch [file join $subpath $match] + set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] + foreach file $files { + set excluded 0 + foreach glob $excludes { + if {[string match $glob $file]} { + set excluded 1 + break + } + } + if {!$excluded} {lappend result $file} + } + foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { + set subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] + if {[llength $subdir_entries]>0} { + #NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" + #This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash + #Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. + set result [list {*}$result "$dir/" {*}$subdir_entries] + } + } + return $result + } + + #if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) + #Otherwise extract an internal preamble. + #if neither - + #review - reconsider auto-determination of internal vs external preamble + proc extract_preamble {infile outfile_preamble {outfile_zip ""}} { + set inzip [open $infile r] + fconfigure $inzip -encoding iso8859-1 -translation binary + if {[file exists $outfile_preamble]} { + error "outfile_preamble $outfile_preamble already exists - please remove first" + } + if {$outfile_zip ne ""} { + if {[file exists $outfile_zip] && [file size $outfile_zip]} { + error "outfile_zip $outfile_zip already exists - please remove first" + } + } + chan seek $inzip 0 end + set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent + chan seek $inzip 0 start + #only scan last 64k - cover max signature size?? review + if {$insize < 65559} { + set tailsearch_start 0 + } else { + set tailsearch_start [expr {$insize - 65559}] + } + chan seek $inzip $tailsearch_start start + set scan [read $inzip] + #EOCD - End Of Central Directory record + set start_of_end [string last "\x50\x4b\x05\x06" $scan] + puts stdout "==>start_of_end: $start_of_end" + + if {$start_of_end == -1} { + #no zip eocdr - consider entire file to be the zip preamble + set baseoffset $insize + } else { + set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] + chan seek $inzip $filerelative_eocd_posn + set cdir_record_plus [read $inzip] ;#can have trailing data + binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + #rule out a false positive from within a nonzip (e.g plain exe) + #There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. + #It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway + #we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros + #todo - just search for Pk\5\6\0\0\0\0 in the first place? //review + if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { + #review - should keep searching? + #for now we assume not a zip + set baseoffset $insize + } else { + #use the central dir size to jump back tko start of central dir + #determine if diroffset is file or archive relative + + set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] + puts stdout "---> [read $inzip 4]" + if {$filerelative_cdir_start > $eocd(diroffset)} { + #'external preamble' easy case + # - ie 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier + #though we are assuming zip offsets are not corrupted + set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] + } else { + #'internal preamble' hard case + # - either no preamble - or offsets have been adjusted to be file relative. + #we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers + #we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? + #or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete + + #step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) + #we can't assume they're ordered in any particular way - so we in theory have to look at them all. + set baseoffset "unknown" + chan seek $inzip $filerelative_cdir_start start + #binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + # eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + #load the whole central dir into cdir + + #todo! loop through all cdr file headers - find highest offset? + #tclZipfs.c just looks at first file header in Central Directory + #looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW + + set cdirdata [read $inzip $eocd(dirsize)] + binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ + cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ + cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) + + #since we're in this branch - we assume cdir(relativeoffset) is from the start of the file + chan seek $inzip $cdir(relativeoffset) + #let's at least check that we landed on a local file header.. + set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field + binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ + lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) + #dec2hex 67324752 = 4034B50 = PK\3\4 + puts stdout "1st local file header sig: $lfh(signature)" + if {$lfh(signature) == 67324752} { + #looks like a local file header + #use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) + set baseoffset $cdir(relativeoffset) + } + } + puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" + } + } + puts stdout "baseoffset: $baseoffset" + #expect CDFH PK\1\2 + #above the CD - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) + #above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script + + if {![string is integer -strict $baseoffset]} { + error "unable to determine zip baseoffset of file $infile" + } + + if {$baseoffset < $insize} { + set pout [open $outfile_preamble w] + fconfigure $pout -encoding iso8859-1 -translation binary + chan seek $inzip 0 start + chan copy $inzip $pout -size $baseoffset + close $pout + if {$outfile_zip ne ""} { + #todo - if it was internal preamble - need to adjust offsets to fix the split off zipfile + set zout [open $outfile_zip w] + fconfigure $zout -encoding iso8859-1 -translation binary + chan copy $inzip $zout + close $zout + } + close $inzip + } else { + #no valid (from our perspective) eocdr found - baseoffset has been set to insize + close $inzip + file copy $infile $outfile_preamble + if {$outfile_zip ne ""} { + #touch equiv? + set fd [open $outfile_zip w] + close $fd + } + } + } + + + + # Addentry - was Mkzipfile -- + # + # FIX ME: should handle the current offset for non-seekable channels + # + proc Addentry {args} { + #*** !doctools + #[call [fun Addentry] [arg zipchan] [arg base] [arg path] [arg ?comment?]] + #[para] Add a single file to a zip archive + #[para] The zipchan channel should already be open and binary. + #[para] You can provide a -comment for the file. + #[para] The return value is the central directory record that will need to be used when finalizing the zip archive. + + set argd [punk::args::get_dict { + *proc -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' + return a central directory file record" + *opts + -comment -default "" -help "An optional comment specific to the added file" + *values -min 3 -max 4 + zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" + base -help "base path for entries" + path -type file -help "path of file to add" + zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe + Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" + } $args] + + set zipchan [dict get $argd values zipchan] + set base [dict get $argd values base] + set path [dict get $argd values path] + set zipdataoffset [dict get $argd values zipdataoffset] + + set comment [dict get $argd opts -comment] + + set fullpath [file join $base $path] + set mtime [Timet_to_dos [file mtime $fullpath]] + set utfpath [encoding convertto utf-8 $path] + set utfcomment [encoding convertto utf-8 $comment] + set flags [expr {(1<<11)}] ;# utf-8 comment and path + set method 0 ;# store 0, deflate 8 + set attr 0 ;# text or binary (default binary) + set version 20 ;# minumum version req'd to extract + set extra "" + set crc 0 + set size 0 + set csize 0 + set data "" + set seekable [expr {[tell $zipchan] != -1}] + if {[file isdirectory $fullpath]} { + set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) + #set attrex 0x40000010 + } elseif {[file executable $fullpath]} { + set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) + } else { + set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) + if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { + set attr 1 ;# text + } + } + + if {[file isfile $fullpath]} { + set size [file size $fullpath] + if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} + } + + + set channeloffset [tell $zipchan] ;#position in the channel - this may include prefixing exe/zip + set local [binary format a4sssiiiiss PK\03\04 \ + $version $flags $method $mtime $crc $csize $size \ + [string length $utfpath] [string length $extra]] + append local $utfpath $extra + puts -nonewline $zipchan $local + + if {[file isfile $fullpath]} { + # If the file is under 2MB then zip in one chunk, otherwize we use + # streaming to avoid requiring excess memory. This helps to prevent + # storing re-compressed data that may be larger than the source when + # handling PNG or JPEG or nested ZIP files. + if {$size < 0x00200000} { + set fin [open $fullpath rb] + set data [read $fin] + set crc [zlib crc32 $data] + set cdata [zlib deflate $data] + if {[string length $cdata] < $size} { + set method 8 + set data $cdata + } + close $fin + set csize [string length $data] + puts -nonewline $zipchan $data + } else { + set method 8 + set fin [open $fullpath rb] + set zlib [zlib stream deflate] + while {![eof $fin]} { + set data [read $fin 4096] + set crc [zlib crc32 $data $crc] + $zlib put $data + if {[string length [set zdata [$zlib get]]]} { + incr csize [string length $zdata] + puts -nonewline $zipchan $zdata + } + } + close $fin + $zlib finalize + set zdata [$zlib get] + incr csize [string length $zdata] + puts -nonewline $zipchan $zdata + $zlib close + } + + if {$seekable} { + # update the header if the output is seekable + set local [binary format a4sssiiii PK\03\04 \ + $version $flags $method $mtime $crc $csize $size] + set current [tell $zipchan] + seek $zipchan $channeloffset + puts -nonewline $zipchan $local + seek $zipchan $current + } else { + # Write a data descriptor record + set ddesc [binary format a4iii PK\7\8 $crc $csize $size] + puts -nonewline $zipchan $ddesc + } + } + + #PK\x01\x02 Cdentral directory file header + #set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 + set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) + + set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ + $version $flags $method $mtime $crc $csize $size \ + [string length $utfpath] [string length $extra]\ + [string length $utfcomment] 0 $attr $attrex [expr {$channeloffset - $zipdataoffset}]] ;#zipdataoffset may be zero - either because it's a pure zip, or file-based offsets desired. + append hdr $utfpath $extra $utfcomment + return $hdr + } + + #### REVIEW!!! + #JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') + # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) + #### + + # zip::mkzip -- + # + # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt + # + proc mkzip {args} { + #todo - doctools - [arg ?globs...?] syntax? + + #*** !doctools + #[call [fun mkzip] [arg ?options?] [arg filename] ] + #[para] Create a zip archive in 'filename' + #[para] If a file already exists, an error will be raised. + set argd [punk::args::get_dict { + *proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" + *opts + -offsettype -default "archive" -choices {archive file} -help "zip offsets stored relative to start of entire file or relative to start of zip-archive + Only relevant if the created file has a script/runtime prefix. + " + -return -default "pretty" -choices {pretty list none} -help "mkzip can return a list of the files and folders added to the archive + the option -return pretty is the default and uses the punk::lib pdict/plist system + to return a formatted list for the terminal + " + -zipkit -default 0 -type none -help "whether to add mounting script + mutually exclusive with -runtime option + currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs + " + -runtime -default "" -help "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + Expects runtime with no existing vfs attached (review) + " + -comment -default "" -help "An optional comment for the archive" + -directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" + -base -default "" -help "The new zip archive will be rooted in this directory if provided + it must be a parent of -directory or the same path as -directory" + -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + *values -min 1 -max -1 + filename -type file -default "" -help "name of zipfile to create" + globs -default {*} -multiple 1 -help "list of glob patterns to match. + Only directories with matching files will be included in the archive" + } $args] + + set filename [dict get $argd values filename] + if {$filename eq ""} { + error "mkzip filename cannot be empty string" + } + if {[regexp {[?*]} $filename]} { + #catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name + error "mkzip filename should not contain glob characters ? *" + } + if {[file exists $filename]} { + error "mkzip filename:$filename already exists" + } + dict for {k v} [dict get $argd opts] { + switch -- $k { + -comment { + dict set argd opts $k [encoding convertto utf-8 $v] + } + -directory - -base { + dict set argd opts $k [file normalize $v] + } + } + } + + array set opts [dict get $argd opts] + + + if {$opts(-directory) ne ""} { + if {$opts(-base) ne ""} { + #-base and -directory have been normalized already + if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { + error "punk::zip::mkzip -base $opts(-base) must be above or the same as -directory $opts(-directory)" + } + set base $opts(-base) + set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] + } else { + set base $opts(-directory) + set relpath "" + } + set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] + + set norm_filename [file normalize $filename] + set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) + if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { + #check that we aren't adding the zipfile to itself + #REVIEW - now that we open zipfile after scanning - this isn't really a concern! + #keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) + #In the case of -force - we may want to delay replacement of original until scan is done? + + #try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each + #1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths + set self_globs_match 0 + foreach g [dict get $argd values globs] { + if {[string match $g [file tail $filename]]} { + set self_globs_match 1 + break + } + } + if {$self_globs_match} { + #still dangerous + set self_excluded 0 + foreach e $opts(-exclude) { + if {[string match $e [file tail $filename]]} { + set self_excluded 1 + break + } + } + if {!$self_excluded} { + #still dangerous - likely to be in resultset - check each path + #puts stderr "zip file $filename is below directory $opts(-directory)" + set self_is_matched 0 + set i 0 + foreach p $paths { + set norm_p [file normalize [file join $opts(-directory) $p]] + if {[Path_a_at_b $norm_filename $norm_p]} { + set self_is_matched 1 + break + } + incr i + } + if {$self_is_matched} { + puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" + set paths [lremove $paths $i] + } + } + } + } + } else { + set paths [list] + set dir [pwd] + if {$opts(-base) ne ""} { + if {![Path_a_atorbelow_b $dir $opts(-base)]} { + error "punk::zip::mkzip -base $opts(-base) must be above current directory" + } + set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] + } else { + set relpath "" + } + set base $opts(-base) + + set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] + foreach m $matches { + if {$m eq $filename} { + #puts stderr "--> excluding $filename" + continue + } + set isok 1 + foreach e [concat $opts(-exclude) $filename] { + if {[string match $e $m]} { + set isok 0 + break + } + } + if {$isok} { + lappend paths [file join $relpath $m] + } + } + } + + if {![llength $paths]} { + return "" + } + + set zf [open $filename wb] + if {$opts(-runtime) ne ""} { + #todo - strip any existing vfs - option to merge contents.. only if zip attached? + set rt [open $opts(-runtime) rb] + fcopy $rt $zf + close $rt + } elseif {$opts(-zipkit)} { + #TODO - update to zipfs ? + #see modpod + set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" + append zkd "package require vfs::zip\n" + append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" + append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" + append zkd " source \[file join \[info script\] main.tcl\]\n" + append zkd "}\n" + append zkd \x1A + puts -nonewline $zf $zkd + } + + #todo - subtract this from the endrec offset + if {$opts(-offsettype) eq "archive"} { + set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024 + } else { + set dataStartOffset 0 ;#offsets relative to file - the zipfs mkzip way :/ + } + + set count 0 + set cd "" + + set members [list] + foreach path $paths { + #puts $path + lappend members $path + append cd [Addentry $zf $base $path $dataStartOffset] ;#path already includes relpath + incr count + } + set cdoffset [tell $zf] + set endrec [binary format a4ssssiis PK\05\06 0 0 \ + $count $count [string length $cd] $cdoffset\ + [string length $opts(-comment)]] + append endrec $opts(-comment) + puts -nonewline $zf $cd + puts -nonewline $zf $endrec + close $zf + + set result "" + switch -exact -- $opts(-return) { + list { + set result $members + } + pretty { + if {[info commands showlist] ne ""} { + set result [plist -channel none members] + } else { + set result $members + } + } + none { + set result "" + } + } + return $result + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::zip ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::zip::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::zip::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::zip::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval punk::zip::system { + #*** !doctools + #[subsection {Namespace punk::zip::system}] + #[para] Internal functions that are not part of the API + + + +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::zip [tcl::namespace::eval punk::zip { + variable pkg punk::zip + variable version + set version 0.1.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/bootsupport/modules/textblock-0.1.1.tm b/src/bootsupport/modules/textblock-0.1.1.tm index b822b353..d7a828a4 100644 --- a/src/bootsupport/modules/textblock-0.1.1.tm +++ b/src/bootsupport/modules/textblock-0.1.1.tm @@ -5080,6 +5080,19 @@ tcl::namespace::eval textblock { # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| # >} punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] + set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] + set testblock [textblock::testblock 15 rainbow] + set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] + set framed [textblock::frame -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] + } + + proc example {args} { set opts [tcl::dict::create -forcecolour 0] foreach {k v} $args { @@ -5248,6 +5261,7 @@ tcl::namespace::eval textblock { if {[tcl::dict::exists $framedef_cache $cache_key]} { return [tcl::dict::get $framedef_cache $cache_key] } + set argopts [lrange $args 0 end-1] set f [lindex $args end] @@ -5279,10 +5293,10 @@ tcl::namespace::eval textblock { -boxonly -default 0 -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 -help "name from the predefined frametypes: - or an adhoc " + frametype -choices "" -choiceprefix 0 -help "name from the predefined frametypes + or an adhoc dictionary." }] - append spec \n "frametype -help \"A predefined \"" + #append spec \n "frametype -help \"A predefined \"" punk::args::get_dict $spec $args return } diff --git a/src/bootsupport/modules/textblock-0.1.2.tm b/src/bootsupport/modules/textblock-0.1.2.tm new file mode 100644 index 00000000..8d24e650 --- /dev/null +++ b/src/bootsupport/modules/textblock-0.1.2.tm @@ -0,0 +1,7441 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application textblock 0.1.2 +# Meta platform tcl +# Meta license +# @@ Meta End + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_textblock 0 0.1.2] +#[copyright "2024"] +#[titledesc {punk textblock functions}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] +#[require textblock] +#[keywords module utility lib] +#[description] +#[para] Ansi-aware terminal textblock manipulation + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of textblock +#[subsection Concepts] +#[para] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by textblock +#[list_begin itemized] + +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] +#[item] [package {punk::char}] +#[item] [package {punk::ansi}] +#[item] [package {punk::lib}] +#[item] [package {overtype}] +#[item] [package {term::ansi::code::macros}] +#[item] [package {textutil}] + +## Requirements +package require Tcl 8.6- +package require punk::args +package require punk::char +package require punk::ansi +package require punk::lib +catch {package require patternpunk} +package require overtype + +#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. +package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? +package require textutil + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval textblock { + #review - what about ansi off in punk::console? + tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ + tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock + variable use_md5 ;#framecache + set use_md5 1 + if {[catch {package require md5}]} { + set use_md5 0 + } + proc use_md5 {{yes_no ""}} { + variable use_md5 + if {$yes_no eq ""} { + return $use_md5 + } + if {![string is boolean -strict $yes_no]} { + error "textblock::use_md5 requires a boolean (or empty string to query)" + } + if {$yes_no} { + package require md5 + set use_md5 1 + } else { + set use_md5 0 + } + return $use_md5 + } + tcl::namespace::eval class { + variable opts_table_defaults + set opts_table_defaults [tcl::dict::create\ + -title ""\ + -titlealign "left"\ + -titletransparent 0\ + -frametype "light"\ + -frametype_header ""\ + -ansibase_header ""\ + -ansibase_body ""\ + -ansibase_footer ""\ + -ansiborder_header ""\ + -ansiborder_body ""\ + -ansiborder_footer ""\ + -ansireset "\uFFeF"\ + -framelimits_header "vll vlr hlb hlt tlc trc blc brc"\ + -frametype_body ""\ + -framelimits_body "vll vlr hlb hlt tlc trc blc brc"\ + -framemap_body [list\ + topleft {} topinner {} topright {} topsolo {}\ + middleleft {} middleinner {} middleright {} middlesolo {}\ + bottomleft {} bottominner {} bottomright {} bottomsolo {}\ + onlyleft {} onlyinner {} onlyright {} onlysolo {}\ + ]\ + -framemap_header [list\ + topleft {} topinner {} topright {} topsolo {}\ + middleleft {} middleinner {} middleright {} middlesolo {}\ + bottomleft {} bottominner {} bottomright {} bottomsolo {}\ + onlyleft {} onlyinner {} onlyright {} onlysolo {}\ + ]\ + -show_edge 1\ + -show_seps 1\ + -show_hseps ""\ + -show_vseps ""\ + -show_header ""\ + -show_footer ""\ + -minwidth ""\ + -maxwidth ""\ + ] + variable opts_column_defaults + set opts_column_defaults [tcl::dict::create\ + -headers [list]\ + -header_colspans [list]\ + -footers [list]\ + -defaultvalue ""\ + -ansibase ""\ + -ansireset "\uFFEF"\ + -minwidth ""\ + -maxwidth ""\ + -blockalign centre\ + -textalign left\ + ] + #initialise -ansireset with replacement char so we can keep in appropriate dict position for initial configure and then treat as read-only + + + + #for 'L' shaped table building pattern (tables bigger than 4x4 will be mostly 'L' patterns) + #ie only vll,blc,hlb used for cells except top row and right column + #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) + #right cells use 'U' shape (vll,blc,hlb,brc,vlr) + #e.g for 4x4 + # C C C O + # L L L U + # L L L U + #anti-clockwise elements + set C [list hlt tlc vll blc hlb] + set O [list trc hlt tlc vll blc hlb brc vlr] + set L [list vll blc hlb] + set U [list vll blc hlb brc vlr] + set tops [list trc hlt tlc] + set lefts [list tlc vll blc] + set bottoms [list blc hlb brc] + set rights [list trc brc vlr] + + variable table_edge_parts + set table_edge_parts [tcl::dict::create\ + topleft [struct::set intersect $C [concat $tops $lefts]]\ + topinner [struct::set intersect $C [concat $tops]]\ + topright [struct::set intersect $O [concat $tops $rights]]\ + topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ + middleleft [struct::set intersect $L $lefts]\ + middleinner [list]\ + middleright [struct::set intersect $U $rights]\ + middlesolo [struct::set intersect $U [concat $lefts $rights]]\ + bottomleft [struct::set intersect $L [concat $lefts $bottoms]]\ + bottominner [struct::set intersect $L $bottoms]\ + bottomright [struct::set intersect $U [concat $bottoms $rights]]\ + bottomsolo [struct::set intersect $U [concat $lefts $bottoms $rights]]\ + onlyleft [struct::set intersect $C [concat $tops $lefts $bottoms]]\ + onlyinner [struct::set intersect $C [concat $tops $bottoms]]\ + onlyright [struct::set intersect $O [concat $tops $bottoms $rights]]\ + onlysolo [struct::set intersect $O [concat $tops $lefts $bottoms $rights]]\ + ] + + #for header rows - we don't consider the bottom border as part of the edge - even if table body has no rows + #The usual-case of a single header line is the 'onlyleft,onlyinner,onlyright,onlysolo' set. + variable header_edge_parts + set header_edge_parts [tcl::dict::create\ + topleft [struct::set intersect $C [concat $tops $lefts]]\ + topinner [struct::set intersect $C [concat $tops]]\ + topright [struct::set intersect $O [concat $tops $rights]]\ + topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ + middleleft [struct::set intersect $L $lefts]\ + middleinner [list]\ + middleright [struct::set intersect $U $rights]\ + middlesolo [struct::set intersect $U [concat $lefts $rights]]\ + bottomleft [struct::set intersect $L [concat $lefts]]\ + bottominner [list]\ + bottomright [struct::set intersect $U $rights]\ + bottomsolo [struct::set intersect $U [concat $lefts $rights]]\ + onlyleft [struct::set intersect $C [concat $tops $lefts]]\ + onlyinner [struct::set intersect $C $tops]\ + onlyright [struct::set intersect $O [concat $tops $rights]]\ + onlysolo [struct::set intersect $O [concat $tops $lefts $rights]]\ + ] + variable table_hseps + set table_hseps [tcl::dict::create\ + topleft [list blc hlb]\ + topinner [list blc hlb]\ + topright [list blc hlb brc]\ + topsolo [list blc hlb brc]\ + middleleft [list blc hlb]\ + middleinner [list blc hlb]\ + middleright [list blc hlb brc]\ + middlesolo [list blc hlb brc]\ + bottomleft [list]\ + bottominner [list]\ + bottomright [list]\ + bottomsolo [list]\ + onlyleft [list]\ + onlyinner [list]\ + onlyright [list]\ + onlysolo [list]\ + ] + variable table_vseps + set table_vseps [tcl::dict::create\ + topleft [list]\ + topinner [list vll tlc blc]\ + topright [list vll tlc blc]\ + topsolo [list]\ + middleleft [list]\ + middleinner [list vll tlc blc]\ + middleright [list vll tlc blc]\ + middlesolo [list]\ + bottomleft [list]\ + bottominner [list vll tlc blc]\ + bottomright [list vll tlc blc]\ + bottomsolo [list]\ + onlyleft [list]\ + onlyinner [list vll tlc blc]\ + onlyright [list vll tlc blc]\ + onlysolo [list]\ + ] + + #ensembles seem to be not compiled in safe interp + #https://core.tcl-lang.org/tcl/tktview/1095bf7f75 + #as we want textblock to be usable in safe interps - use tcl::dict::for as a partial workaround + #This at least means the script argument, especially switch statements can get compiled. + #It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp. + + #e.g $t configure -framemap_body [table_edge_map " "] + proc table_edge_map {char} { + variable table_edge_parts + set map [list] + tcl::dict::for {celltype parts} $table_edge_parts { + set tmap [list] + foreach p $parts { + tcl::dict::set tmap $p $char + } + tcl::dict::set map $celltype $tmap + } + return $map + } + proc table_sep_map {char} { + variable table_hseps + set map [list] + tcl::dict::for {celltype parts} $table_hseps { + set tmap [list] + foreach p $parts { + tcl::dict::set tmap $p $char + } + tcl::dict::set map $celltype $tmap + } + return $map + } + proc header_edge_map {char} { + variable header_edge_parts + set map [list] + tcl::dict::for {celltype parts} $header_edge_parts { + set tmap [list] + foreach p $parts { + tcl::dict::set tmap $p $char + } + tcl::dict::set map $celltype $tmap + } + return $map + } + + if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} { + #*** !doctools + #[subsection {Namespace textblock::class}] + #[para] class definitions + #[list_begin itemized] [comment {- textblock::class groupings -}] + # [item] + # [para] [emph {handler_classes}] + # [list_begin enumerated] + + #this makes new table objects a little faster when multiple opts specified as well as to configure + #as tables are a heavyweight thing, but handy to nest sometimes - we'll take what we can get + set topt_keys [tcl::dict::keys $::textblock::class::opts_table_defaults] + set switch_keys_valid_topts [punk::lib::lmapflat v $topt_keys {list $v -}] + set switch_keys_valid_topts [lrange $switch_keys_valid_topts 0 end-1] ;#remove last dash + + set copt_keys [tcl::dict::keys $::textblock::class::opts_column_defaults] + set switch_keys_valid_copts [punk::lib::lmapflat v $copt_keys {list $v -}] + set switch_keys_valid_copts [lrange $switch_keys_valid_copts 0 end-1] + + oo::class create [tcl::namespace::current]::table [tcl::string::map [list %topt_keys% $topt_keys %topt_switchkeys% $switch_keys_valid_topts %copt_keys% $copt_keys %copt_switchkeys% $switch_keys_valid_copts] { + #*** !doctools + #[enum] CLASS [class textblock::class::table] + #[list_begin definitions] + # [para] [emph METHODS] + variable o_opts_table ;#options as configured by user (with exception of -ansireset) + variable o_opts_table_effective; #options in effect - e.g with defaults merged in. + + variable o_columndefs + variable o_columndata + variable o_columnstates + variable o_headerstates + + variable o_rowdefs + variable o_rowstates + + variable o_opts_table_defaults + variable o_opts_header_defaults ;# header data mostly stored in o_columndefs + variable o_opts_column_defaults + variable o_opts_row_defaults + variable TSUB ;#make configurable so user isn't stopped from using our default PUA-unicode char in content (nerdfonts overlap) + variable o_calculated_column_widths + variable o_column_width_algorithm + + + constructor {args} { + #*** !doctools + #[call class::table [method constructor] [arg args]] + set o_opts_table_defaults $::textblock::class::opts_table_defaults + set o_opts_column_defaults $::textblock::class::opts_column_defaults + + + if {[llength $args] == 1} { + set args [list -title [lindex $args 0]] + } + if {[llength $args] %2 !=0} { + error "[tcl::namespace::current]::table constructor - unexpected argument count. Require single value being title, or name value pairs" + } + + set o_opts_table $o_opts_table_defaults + set o_opts_table_effective $o_opts_table_defaults + + ##todo - test with punk::lib::show_jump_tables - how? + foreach {k v} $args { + switch -- $k { + %topt_switchkeys% { + tcl::dict::set o_opts_table $k $v + } + default { + error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + } + } + } + my configure {*}$o_opts_table + + #foreach {k v} $args { + # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. + # if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { + # error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + # } + #} + #set o_opts_table [tcl::dict::merge $o_opts_table_defaults $args] + #my configure {*}[tcl::dict::merge $o_opts_table_defaults $args] + + set o_columndefs [tcl::dict::create] + set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row + set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly + set o_headerstates [tcl::dict::create] + set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight + set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data + + set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices. + set o_calculated_column_widths [list] + set o_column_width_algorithm "span" + set header_defaults [tcl::dict::create\ + -colspans {}\ + -values {}\ + -ansibase {}\ + ] + set o_opts_header_defaults $header_defaults + } + + method width_algorithm {{alg ""}} { + if {$alg eq ""} { + return $o_column_width_algorithm + } + if {$alg ne $o_column_width_algorithm} { + #invalidate cached widths + set o_calculated_column_widths [list] + } + set o_column_width_algorithm $alg + } + method Get_seps {} { + set requested_seps [tcl::dict::get $o_opts_table -show_seps] + set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] + set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] + set seps $requested_seps + set seps_h $requested_seps_h + set seps_v $requested_seps_v + if {$requested_seps eq ""} { + if {$requested_seps_h eq ""} { + set seps_h 1 + } + if {$requested_seps_v eq ""} { + set seps_v 1 + } + } else { + if {$requested_seps_h eq ""} { + set seps_h $seps + } + if {$requested_seps_v eq ""} { + set seps_v $seps + } + } + return [tcl::dict::create horizontal $seps_h vertical $seps_v] + } + method Get_frametypes {} { + set requested_ft [tcl::dict::get $o_opts_table -frametype] + set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] + set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] + set ft $requested_ft + set ft_header $requested_ft_header + set ft_body $requested_ft_body + switch -- $requested_ft { + light { + if {$requested_ft_header eq ""} { + set ft_header heavy + } + if {$requested_ft_body eq ""} { + set ft_body light + } + } + default { + if {$requested_ft_header eq ""} { + set ft_header $requested_ft + } + if {$requested_ft_body eq ""} { + set ft_body $requested_ft + } + } + } + return [tcl::dict::create header $ft_header body $ft_body] + } + method Set_effective_framelimits {} { + upvar ::textblock::class::opts_table_defaults tdefaults + set default_blims [tcl::dict::get $tdefaults -framelimits_body] + set default_hlims [tcl::dict::get $tdefaults -framelimits_header] + set eff_blims [tcl::dict::get $o_opts_table_effective -framelimits_body] + set eff_hlims [tcl::dict::get $o_opts_table_effective -framelimits_header] + + set requested_blims [tcl::dict::get $o_opts_table -framelimits_body] + set requested_hlims [tcl::dict::get $o_opts_table -framelimits_header] + set blims $eff_blims + set hlims $eff_hlims + switch -- $requested_blims { + "default" { + set blims $default_blims + } + default { + #set blims $requested_blims + set blims [list] + foreach lim $requested_blims { + switch -- $lim { + hl { + lappend blims hlt hlb + } + vl { + lappend blims vll vlr + } + default { + lappend blims $lim + } + } + } + set blims [lsort -unique $blims] + } + } + tcl::dict::set o_opts_table_effective -framelimits_body $blims + switch -- $requested_hlims { + "default" { + set hlims $default_hlims + } + default { + #set hlims $requested_hlims + set hlims [list] + foreach lim $requested_hlims { + switch -- $lim { + hl { + lappend hlims hlt hlb + } + vl { + lappend hlims vll vlr + } + default { + lappend hlims $lim + } + } + } + set hlims [lsort -unique $hlims] + } + } + tcl::dict::set o_opts_table_effective -framelimits_header $hlims + return [tcl::dict::create body $blims header $hlims] + } + method configure args { + if {![llength $args]} { + return $o_opts_table + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [list %topt_keys%]} { + #query single option + set k [lindex $args 0] + set val [tcl::dict::get $o_opts_table $k] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + set infodict [tcl::dict::create] + switch -- $k { + -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder_body - -ansiborder_footer { + tcl::dict::set infodict debug [ansistring VIEW $val] + } + -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { + tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] + } + } + tcl::dict::set returndict info $infodict + return $returndict + #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_table_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "[tcl::namespace::current]::table configure - unexpected argument count. Require name value pairs" + } + foreach {k v} $args { + switch -- $k { + %topt_switchkeys% {} + default { + error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + } + } + #if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { + # error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" + #} + } + set checked_opts [list] + foreach {k v} $args { + switch -- $k { + -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set ansi_codes [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend ansi_codes $code + } + } + set ansival [punk::ansi::codetype::sgr_merge_singles $ansi_codes] + lappend checked_opts $k $ansival + } + -frametype - -frametype_header - -frametype_body { + #frametype will raise an error if v is not a valid custom dict or one of the known predefined types such as light,heavy,double etc + lassign [textblock::frametype $v] _cat category _type ftype + lappend checked_opts $k $v + } + -framemap_body - -framemap_header { + #upvar ::textblock::class::opts_table_defaults tdefaults + #set default_bmap [tcl::dict::get $tdefaults -framemap_body] + #todo - check keys and map + if {[llength $v] == 1} { + if {$v eq "default"} { + upvar ::textblock::class::opts_table_defaults tdefaults + set default_map [tcl::dict::get $tdefaults $k] + lappend checked_opts $k $default_map + } else { + error "textblock::table::configure invalid $k value $v. Expected the value 'default' or a dict e.g topleft {hl *}" + } + } else { + #safe jumptable test + #dict for {subk subv} $v {} + foreach {subk subv} $v { + switch -- $subk { + topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} + default { + error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" + } + } + #safe jumptable test + #dict for {seg subst} $subv {} + foreach {seg subst} $subv { + switch -- $seg { + hl - hlt - hlb - vl - vll - vlr - trc - tlc - blc - brc {} + default { + error "textblock::table::configure invalid $subk value $seg. Known values {hl hlt hlb vl vll vlr trc tlc blc brc}" + } + } + } + + } + lappend checked_opts $k $v + } + + } + -framelimits_body - -framelimits_header { + set specific_framelimits [list] + foreach fl $v { + switch -- $fl { + "default" { + lappend specific_framelimits trc hlt tlc vll blc hlb brc vlr + } + hl { + lappend specific_framelimits hlt hlb + } + vl { + lappend specific_framelimits vll vlr + } + hlt - hlb - vll - vlr - trc - tlc - blc - brc { + lappend specific_framelimits $fl + } + default { + error "textblock::table::configure invalid $k '$fl'. Known values {hl hlb hlt vl vll vlr trc tlc blc brc} (or default for all)" + } + } + } + lappend checked_opts $k $specific_framelimits + } + -ansireset { + if {$v eq "\uFFEF"} { + set RST "\x1b\[m" ;#[a] + lappend checked_opts $k $RST + } else { + error "textblock::table::configure -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -show_hseps { + if {![tcl::string::is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + lappend checked_opts $k $v + #these don't affect column width calculations + } + -show_edge { + if {![tcl::string::is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + lappend checked_opts $k $v + #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + } + -show_vseps { + #we allow empty string - so don't use -strict boolean check + if {![tcl::string::is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + #affects width calculations + set o_calculated_column_widths [list] + lappend checked_opts $k $v + } + -minwidth - -maxwidth { + set o_calculated_column_widths [list] + lappend checked_opts $k $v + } + default { + lappend checked_opts $k $v + } + } + } + #all options checked - ok to update o_opts_table and o_opts_table_effective + + #set o_opts_table [tcl::dict::merge $o_opts_table $checked_opts] + foreach {k v} $args { + switch -- $k { + -framemap_header - -framemap_body { + #framemaps don't require setting every key to update. + #e.g configure -framemaps {topleft } + #needs to merge with existing unspecified keys such as topright middleleft etc. + if {$v eq "default"} { + tcl::dict::set o_opts_table $k default + } else { + if {[tcl::dict::get $o_opts_table $k] eq "default"} { + tcl::dict::set o_opts_table $k $v + } else { + tcl::dict::set o_opts_table $k [tcl::dict::merge [tcl::dict::get $o_opts_table $k] $v] + } + } + } + default { + tcl::dict::set o_opts_table $k $v + } + } + } + #use values from checked_opts for the effective opts + #safe jumptable test + #dict for {k v} $checked_opts {} + #foreach {k v} $checked_opts {} + tcl::dict::for {k v} $checked_opts { + switch -- $k { + -framemap_body - -framemap_header { + set existing [tcl::dict::get $o_opts_table_effective $k] + #set updated $existing + #dict for {subk subv} $v { + # tcl::dict::set updated $subk $subv + #} + #tcl::dict::set o_opts_table_effective $k $updated + tcl::dict::set o_opts_table_effective $k [tcl::dict::merge $existing $v] + } + -framelimits_body - -framelimits_header { + #my Set_effective_framelimits + tcl::dict::set o_opts_table_effective $k $v + } + default { + tcl::dict::set o_opts_table_effective $k $v + } + } + } + #ansireset exception + tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] + return $o_opts_table + } + + #integrate with struct::matrix - allows ::m format 2string $table + method printmatrix {matrix} { + set matrix_rowcount [$matrix rows] + set matrix_colcount [$matrix columns] + set table_colcount [my column_count] + if {$table_colcount == 0} { + for {set c 0} {$c < $matrix_colcount} {incr c} { + my add_column -headers "" + } + } + set table_colcount [my column_count] + if {$table_colcount != $matrix_colcount} { + error "textblock::table::printmatrix column count of table doesn't match column count of matrix" + } + if {[my row_count] > 0} { + my row_clear + } + for {set r 0} {$r < $matrix_rowcount} {incr r} { + my add_row [$matrix get row $r] + } + my print + } + method as_matrix {{cmd ""}} { + if {$cmd eq ""} { + set m [struct::matrix] + } else { + set m [struct::matrix $cmd] + } + $m add columns [tcl::dict::size $o_columndata] + $m add rows [tcl::dict::size $o_rowdefs] + tcl::dict::for {k v} $o_columndata { + $m set column $k $v + } + return $m + } + method add_column {args} { + #*** !doctools + #[call class::table [method add_column] [arg args]] + + + if {[llength $args] %2 != 0} { + error "[tcl::namespace::current]::table::add_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" + } + set opts $o_opts_column_defaults + foreach {k v} $args { + switch -- $k { + %copt_switchkeys% { + tcl::dict::set opts $k $v + } + default { + error "[tcl::namespace::current]::table::add_column unknown option '$k'. Known options: %copt_keys%" + } + } + } + set colcount [tcl::dict::size $o_columndefs] + + + tcl::dict::set o_columndata $colcount [list] + #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists + tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists + + + tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] + set prev_calculated_column_widths $o_calculated_column_widths + if {[catch { + my configure_column $colcount {*}$opts + } errMsg]} { + #configure failed - ensure o_columndata and o_columndefs entries are removed + tcl::dict::unset o_columndata $colcount + tcl::dict::unset o_columndefs $colcount + tcl::dict::unset o_columnstates $colcount + #undo cache invalidation + set o_calculated_column_widths $prev_calculated_column_widths + error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" + } + #any add_column that succeeds should invalidate the calculated column widths + set o_calculated_column_widths [list] + set numrows [my row_count] + if {$numrows > 0} { + #fill column with default values + #puts ">>> adding default values for column $colcount" + set dval [tcl::dict::get $opts -defaultvalue] + set width [textblock::width $dval] + tcl::dict::set o_columndata $colcount [lrepeat $numrows $dval] + tcl::dict::set o_columnstates $colcount maxwidthbodyseen $width + tcl::dict::set o_columnstates $colcount minwidthbodyseen $width + } + return $colcount + } + method column_count {} { + return [tcl::dict::size $o_columndefs] + } + method configure_column {index_expression args} { + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns" + } + if {![llength $args]} { + return [tcl::dict::get $o_columndefs $cidx] + } else { + if {[llength $args] == 1} { + if {[lindex $args 0] in [list %copt_keys%]} { + #query single option + set k [lindex $args 0] + set val [tcl::dict::get $o_columndefs $cidx $k] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + set infodict [tcl::dict::create] + switch -- $k { + -ansibase { + tcl::dict::set infodict debug [ansistring VIEW $val] + } + } + tcl::dict::set returndict info $infodict + return $returndict + } else { + error "textblock::table configure_column - unrecognised option '[lindex $args 0]'. Known values %copt_keys%" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" + } + foreach {k v} $args { + switch -- $k { + %copt_switchkeys% {} + default { + error "[tcl::namespace::current]::table configure_column unknown option '$k'. Known options: %copt_keys%" + } + } + } + set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state + + set hstates $o_headerstates ;#operate on a copy + set colstate [tcl::dict::get $o_columnstates $cidx] + set args_got_headers 0 + set args_got_header_colspans 0 + foreach {k v} $args { + switch -- $k { + -headers { + set args_got_headers 1 + set i 0 + set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. + foreach hdr $v { + set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns + #set this_header_height [textblock::height $hdr] + lassign [textblock::size $hdr] _w this_header_width _h this_header_height + + if {$this_header_height >= $currentmax} { + tcl::dict::set hstates $i maxheightseen $this_header_height + } else { + tcl::dict::set hstates $i maxheightseen $currentmax + } + if {$this_header_width >= $maxseen} { + set maxseen $this_header_width + } + #if {$this_header_width > [tcl::dict::get $colstate maxwidthheaderseen]} { + # tcl::dict::set colstate maxwidthheaderseen $this_header_width + #} + incr i + } + tcl::dict::set colstate maxwidthheaderseen $maxseen + #review - we could avoid some recalcs if we check current width range compared to previous + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -header_colspans { + set args_got_header_colspans 1 + #check columns to left to make sure each new colspan for this column makes sense in the overall context + #user may have to adjust colspans in order left to right to avoid these check errors + #note that 'any' represents span all up to the next non-zero defined colspan. + set cspans [my header_colspans] + set h 0 + if {[llength $v] > [tcl::dict::size $cspans]} { + error "configure_column $cidx -header_colspans. Only [tcl::dict::size $cspans] headers exist. Too many values supplied" + } + foreach s $v { + if {$cidx == 0} { + if {[tcl::string::is integer -strict $s]} { + if {$s < 1} { + error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'any' or a positive integer" + } + } else { + if {$s ne "any" && $s ne ""} { + error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" + } + } + } else { + #if {![tcl::string::is integer -strict $s]} { + # if {$s ne "any" && $s ne ""} { + # error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" + # } + #} else { + set header_spans [tcl::dict::get $cspans $h] + set remaining [lindex $header_spans 0] + if {$remaining ne "any"} { + incr remaining -1 + } + #look at spans defined for previous cols + #we are presuming previous column entries are valid - and only validating if our new entry is ok under that assumption + for {set c 0} {$c < $cidx} {incr c} { + set span [lindex $header_spans $c] + if {$span eq "any"} { + set remaining "any" + } else { + if {$remaining eq "any"} { + if {$span ne "0"} { + #a previous column has ended the 'any' span + set remaining [expr {$span -1}] + } + } else { + if {$span eq "0"} { + incr remaining -1 + } else { + set remaining [expr {$span -1}] + } + #allow to go negative + } + } + } + if {$remaining eq "any"} { + #any int >0 ok - what about 'any' immediately following any? + } else { + if {$remaining > 0} { + if {$s ne "0" && $s ne ""} { + error "configure_column $cidx -header_colspans bad span $s for header '$h'. Remaining span is '$remaining' - so a zero colspan is required" + } + } else { + if {$s == 0} { + error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'any'" + } + } + } + #} + } + incr h + } + #todo - avoid recalc if no change + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -minwidth { + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -maxwidth { + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + tcl::dict::set checked_opts $k $v + } + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set col_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend col_ansibase_items $code + } + } + set col_ansibase [punk::ansi::codetype::sgr_merge_singles $col_ansibase_items] + tcl::dict::set checked_opts $k $col_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + tcl::dict::set checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_column -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -blockalign - -textalign { + switch -- $v { + left - right { + tcl::dict::set checked_opts $k $v + } + centre - centre { + tcl::dict::set checked_opts $k centre + } + } + } + default { + tcl::dict::set checked_opts $k $v + } + } + } + #args checked - ok to update headerstates and columndefs and columnstates + tcl::dict::set o_columndefs $cidx $checked_opts + + set o_headerstates $hstates + tcl::dict::set o_columnstates $cidx $colstate + + if {$args_got_headers} { + #if the headerlist length for this column has shrunk,and it was the longest - we may now have excess entries in o_headerstates + set zero_heights [list] + tcl::dict::for {hidx _v} $o_headerstates { + #pass empty string for exclude_column so we don't exclude our own column + if {[my header_height_calc $hidx ""] == 0} { + lappend zero_heights $hidx + } + } + foreach zidx $zero_heights { + tcl::dict::unset o_headerstates $zidx + } + } + if {$args_got_headers || $args_got_header_colspans} { + #check and adjust header_colspans for all columns + + } + + return [tcl::dict::get $o_columndefs $cidx] + } + } + + method header_count {} { + return [tcl::dict::size $o_headerstates] + } + method header_count_calc {} { + set max_headers 0 + tcl::dict::for {k cdef} $o_columndefs { + set num_headers [llength [tcl::dict::get $cdef -headers]] + set max_headers [expr {max($max_headers,$num_headers)}] + } + return $max_headers + } + method header_height {header_index} { + set idx [lindex [tcl::dict::keys $o_headerstates $header_index]] + return [tcl::dict::get $o_headerstates $idx maxheightseen] + } + + #review - use maxwidth (considering colspans) of each column to determine height after wrapping + # -need to consider whether vertical expansion allowed / maxheight? + method header_height_calc {header_index {exclude_column ""}} { + set dataheight 0 + if {$exclude_column eq ""} { + set exclude_colidx "" + } else { + set exclude_colidx [lindex [tcl::dict::keys $o_columndefs] $exclude_column] + } + tcl::dict::for {cidx cdef} $o_columndefs { + if {$exclude_colidx == $cidx} { + continue + } + set headerlist [tcl::dict::get $cdef -headers] + if {$header_index < [llength $headerlist]} { + set this_height [textblock::height [lindex $headerlist $header_index]] + set dataheight [expr {max($dataheight,$this_height)}] + } + } + return $dataheight + } + + #return a dict keyed on header index with values representing colspans + #e.g + # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} + # + method header_colspans {} { + #set num_headers [my header_count_calc] + set num_headers [my header_count] + set colspans_by_header [tcl::dict::create] + tcl::dict::for {cidx cdef} $o_columndefs { + set headerlist [tcl::dict::get $cdef -headers] + set colspans_for_column [tcl::dict::get $cdef -header_colspans] + for {set h 0} {$h < $num_headers} {incr h} { + set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] + set defined_span [lindex $colspans_for_column $h] + set i 0 + set spanremaining [lindex $headerspans 0] + if {$spanremaining ne "any"} { + if {$spanremaining eq ""} { + set spanremaining 1 + } + incr spanremaining -1 + } + foreach s $headerspans { + if {$s eq "any"} { + set spanremaining "any" + } elseif {$s == 0} { + if {$spanremaining ne "any"} { + incr spanremaining -1 + } + } else { + set spanremaining [expr {$s - 1}] + } + incr i + } + if {$defined_span eq ""} { + if {$spanremaining eq "0"} { + lappend headerspans 1 + } else { + #"any" or an integer + lappend headerspans 0 + } + } else { + lappend headerspans $defined_span + } + tcl::dict::set colspans_by_header $h $headerspans + } + } + return $colspans_by_header + } + + #e.g + # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 any 1} 3 {any 0 0 1} + #convert to + # 0 {4 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} + method header_colspans_numeric {} { + set hcolspans [my header_colspans] + if {![tcl::dict::size $hcolspans]} { + return + } + set numcols [llength [tcl::dict::get $hcolspans 0]] ;#assert: all are the same + tcl::dict::for {h spans} $hcolspans { + set c 0 ;#column index + foreach s $spans { + if {$s eq "any"} { + set spanlen 1 + for {set i [expr {$c+1}]} {$i < $numcols} {incr i} { + #next 'any' or non-zero ends an 'any' span + if {[lindex $spans $i] ne "0"} { + break + } + incr spanlen + } + #overwrite the 'any' with it's actual span + set modified_spans [dict get $hcolspans $h] + lset modified_spans $c $spanlen + dict set hcolspans $h $modified_spans + } + incr c + } + } + return $hcolspans + } + + #should be configure_headerrow ? + method configure_header {index_expression args} { + #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. + #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis + #e.g o_headerstates: 0 {maxheightseen 1} 1 {maxheightseen 2} + set num_headers [my header_count_calc] + set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression] + if {$hidx eq ""} { + error "textblock::table::configure_header - no row defined at index '$hidx'." + } + if {$hidx > $num_headers -1} { + #assert - shouldn't happen + error "textblock::table::configure_header error headerstates data is out of sync" + } + + if {![llength $args]} { + set colspans_by_header [my header_colspans] + set result [tcl::dict::create] + tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] + set header_row_items [list] + tcl::dict::for {cidx cdef} $o_columndefs { + set colheaders [tcl::dict::get $cdef -headers] + set relevant_header [lindex $colheaders $hidx] + #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + } + tcl::dict::set result -values $header_row_items + return $result + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [tcl::dict::keys $o_opts_header_defaults]} { + #query single option + set k [lindex $args 0] + #set val [tcl::dict::get $o_rowdefs $ridx $k] + + set infodict [tcl::dict::create] + #todo + # -blockalignments and -textalignments lists + # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} + #if there is a value it overrides alignments specified on the column + switch -- $k { + -values { + set header_row_items [list] + tcl::dict::for {cidx cdef} $o_columndefs { + set colheaders [tcl::dict::get $cdef -headers] + set relevant_header [lindex $colheaders $hidx] + #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + + } + set val $header_row_items + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + } + -colspans { + set colspans_by_header [my header_colspans] + set result [tcl::dict::create] + set val [tcl::dict::get $colspans_by_header $hidx] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + } + -ansibase { + set val ??? + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + tcl::dict::set infodict debug [ansistring VIEW $val] + } + } + tcl::dict::set returndict info $infodict + return $returndict + #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure_header - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_header_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_header incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_header_defaults]" + } + foreach {k v} $args { + if {$k ni [tcl::dict::keys $o_opts_header_defaults]} { + error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_header_defaults]" + } + } + + set checked_opts [list] + #safe jumptable test + #dict for {k v} $args {} + foreach {k v} $args { + switch -- $k { + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set header_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend header_ansibase_items $code + } + } + set header_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] + error "sorry - -ansibase not yet implemented for header rows" + lappend checked_opts $k $header_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + lappend checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_header -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -values { + if {[llength $v] > [tcl::dict::size $o_columndefs]} { + error "textblock::table::configure_header -values length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" + } + lappend checked_opts $k $v + } + -colspans { + set numcols [tcl::dict::size $o_columndefs] + if {[llength $v] > $numcols} { + error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" + } + if {[llength $v] < $numcols} { + puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." + puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" + } + if {[llength $v]} { + set firstspan [lindex $v 0] + set first_is_ok 0 + if {$firstspan eq "any"} { + set first_is_ok 1 + } elseif {[tcl::string::is integer -strict $firstspan] && $firstspan > 0 && $firstspan <= $numcols} { + set first_is_ok 1 + } + if {!$first_is_ok} { + error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" + } + #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) + set remaining $firstspan + if {$remaining ne "any"} { + incr remaining -1 + } + set spanview $v + set sidx 1 + #because we allow 'any' - be careful when doing < or > comparisons - as we are mixing integer and string comparisons if we don't test for 'any' first + foreach span [lrange $v 1 end] { + if {$remaining eq "any"} { + if {$span eq "any"} { + set remaining "any" + } elseif {$span > 0} { + #ok to reset to higher val immediately or after an any and any number of following zeros + if {$span > ($numcols - $sidx)} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" + } + set remaining $span + incr remaining -1 + } else { + #zero following an any - leave remaining as any + } + } else { + if {$span eq "0"} { + if {$remaining eq "0"} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview" + } else { + incr remaining -1 + } + } else { + if {$remaining eq "0"} { + #ok for new span value of any or > 0 + if {$span ne "any" && $span > ($numcols - $sidx)} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" + } + set remaining $span + if {$remaining ne "any"} { + incr remaining -1 + } + } else { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview" + } + } + } + incr sidx + } + } + #empty -colspans list should be ok + + #error "sorry - -colspans not yet implemented for header rows - set manually in vertical order via configure_column for now" + lappend checked_opts $k $v + } + default { + lappend checked_opts $k $v + } + } + } + + #configured opts all good + #safe jumptable test + #dict for {k v} $checked_opts {} + #foreach {k v} $checked_opts {} + tcl::dict::for {k v} $checked_opts { + switch -- $k { + -values { + set c 0 + foreach hval $v { + #retrieve -headers from relevant col, insert at header index, and write back. + set thiscol_headers_vertical [tcl::dict::get $o_columndefs $c -headers] + set missing [expr {($hidx +1) - [llength $thiscol_headers_vertical]}] + if {$missing > 0} { + lappend thiscol_headers_vertical {*}[lrepeat $missing ""] + } + lset thiscol_headers_vertical $hidx $hval + tcl::dict::set o_columndefs $c -headers $thiscol_headers_vertical + #invalidate column width cache + set o_calculated_column_widths [list] + # -- -- -- -- -- -- + #also update maxwidthseen & maxheightseen + set i 0 + set maxwidthseen 0 + #set maxheightseen 0 + foreach hdr $thiscol_headers_vertical { + lassign [textblock::size $hdr] _w this_header_width _h this_header_height + set maxheightseen [punk::lib::dict_getdef $o_headerstates $i maxheightseen 0] + if {$this_header_height >= $maxheightseen} { + tcl::dict::set o_headerstates $i maxheightseen $this_header_height + } else { + tcl::dict::set o_headerstates $i maxheightseen $maxheightseen + } + if {$this_header_width >= $maxwidthseen} { + set maxwidthseen $this_header_width + } + incr i + } + tcl::dict::set o_columnstates $c maxwidthheaderseen $maxwidthseen + # -- -- -- -- -- -- + incr c + } + } + -colspans { + #sequence has been verified above - we need to split it and store across columns + set c 0 ;#column index + foreach span $v { + set colspans [tcl::dict::get $o_columndefs $c -header_colspans] + if {$hidx > [llength $colspans]-1} { + set colspans_by_header [my header_colspans] + #puts ">>>>>?$colspans_by_header" + #we are allowed to lset only one beyond the current length to append + #but there may be even less or no entries present in a column + # - the ability to underspecify and calculate the missing values makes setting the values complicated. + #use the header_colspans calculation to update only those entries necessary + set spanlist [list] + for {set h 0} {$h < $hidx} {incr h} { + set cspans [tcl::dict::get $colspans_by_header $h] + set requiredval [lindex $cspans $c] + lappend spanlist $requiredval + } + tcl::dict::set o_columndefs $c -header_colspans $spanlist + + set colspans [tcl::dict::get $o_columndefs $c -header_colspans] + } + + lset colspans $hidx $span + tcl::dict::set o_columndefs $c -header_colspans $colspans + incr c + } + } + } + } + } + + method add_row {valuelist args} { + #*** !doctools + #[call class::table [method add_row] [arg args]] + if {[tcl::dict::size $o_columndefs] > 0 && ([llength $valuelist] && [llength $valuelist] != [tcl::dict::size $o_columndefs])} { + set msg "" + append msg "add_row - invalid number ([llength $valuelist]) of values in row - Must match existing column count: [tcl::dict::size $o_columndefs]" \n + append msg "rowdata: $valuelist" + error $msg + } + if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { + error "add_row - no values supplied, and no columns defined, so cannot use default column values" + } + + set defaults [tcl::dict::create\ + -minheight 1\ + -maxheight ""\ + -ansibase ""\ + -ansireset "\uFFEF"\ + ] + set o_opts_row_defaults $defaults + + if {[llength $args] %2 !=0} { + error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" + } + #safe jumptable test + #dict for {k v} $args {} + foreach {k v} $args { + switch -- $k { + -minheight - -maxheight - -ansibase - -ansireset {} + default { + error "Invalid option '$k' Known options: [tcl::dict::keys $defaults] (-ansireset is read-only)" + } + } + } + set opts [tcl::dict::merge $defaults $args] + + set auto_columns 0 + if {[tcl::dict::size $o_columndefs] == 0} { + set auto_columns 1 + #no columns defined - auto define with defaults for each column in first supplied row + #auto define columns only valid if no existing columns + #the autocolumns must be added before configure_row - but if configure_row fails - we need to remove them! + foreach el $valuelist { + my add_column + } + } else { + if {![llength $valuelist]} { + tcl::dict::for {k coldef} $o_columndefs { + lappend valuelist [tcl::dict::get $coldef -defaultvalue] + } + } + } + set rowcount [tcl::dict::size $o_rowdefs] + tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure + + if {[catch { + my configure_row $rowcount {*}$opts + } errMsg]} { + #undo anything we saved before configure_row + tcl::dict::unset o_rowdefs $rowcount + #remove auto_columns + if {$auto_columns} { + set o_columndata [tcl::dict::create] + set o_columndefs [tcl::dict::create] + set o_columnstate [tcl::dict::create] + } + error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" + } + + + set c 0 + set max_height_seen 1 + foreach v $valuelist { + set prev_maxwidth [tcl::dict::get $o_columnstates $c maxwidthbodyseen] + set prev_minwidth [tcl::dict::get $o_columnstates $c minwidthbodyseen] + + tcl::dict::lappend o_columndata $c $v + set valheight [textblock::height $v] + if {$valheight > $max_height_seen} { + set max_height_seen $valheight + } + set width [textblock::width $v] + if {$width > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { + tcl::dict::set o_columnstates $c maxwidthbodyseen $width + } + if {$width < [tcl::dict::get $o_columnstates $c minwidthbodyseen]} { + tcl::dict::set o_columnstates $c minwidthbodyseen $width + } + + if {[tcl::dict::get $o_columnstates $c maxwidthbodyseen] > $prev_maxwidth || [tcl::dict::get $o_columnstates $c minwidthbodyseen] < $prev_minwidth} { + #invalidate calculated column width cache if any new value was outside the previous range of widths + set o_calculated_column_widths [list] + } + incr c + } + + set opt_maxh [tcl::dict::get $o_rowdefs $rowcount -maxheight] + if {$opt_maxh ne ""} { + tcl::dict::set o_rowstates $rowcount -maxheight [expr {min($opt_maxh,$max_height_seen)}] + } else { + tcl::dict::set o_rowstates $rowcount -maxheight $max_height_seen + } + + return $rowcount + } + method configure_row {index_expression args} { + set ridx [lindex [tcl::dict::keys $o_rowdefs] $index_expression] + if {$ridx eq ""} { + error "textblock::table::configure_row - no row defined at index '$ridx'.Use add_row to define rows" + } + if {![llength $args]} { + return [tcl::dict::get $o_rowdefs $ridx] + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [tcl::dict::keys $o_opts_row_defaults]} { + #query single option + set k [lindex $args 0] + set val [tcl::dict::get $o_rowdefs $ridx $k] + set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] + set infodict [tcl::dict::create] + switch -- $k { + -ansibase { + tcl::dict::set infodict debug [ansistring VIEW $val] + } + } + tcl::dict::set returndict info $infodict + return $returndict + #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure_row - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_row_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_row incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_row_defaults]" + } + foreach {k v} $args { + if {$k ni [tcl::dict::keys $o_opts_row_defaults]} { + error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_row_defaults]" + } + } + set checked_opts [list] + foreach {k v} $args { + switch -- $k { + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set row_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend row_ansibase_items $code + } + } + set row_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] + lappend checked_opts $k $row_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + lappend checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_row -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + default { + lappend checked_opts $k $v + } + } + } + + set current_opts [tcl::dict::get $o_rowdefs $ridx] + set opts [tcl::dict::merge $current_opts $checked_opts] + + #check minheight and maxheight together + set opt_minh [tcl::dict::get $opts -minheight] + set opt_maxh [tcl::dict::get $opts -maxheight] + + #todo - allow zero values to hide/collapse rows as is possible with columns + if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { + error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" + } + if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { + error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" + } + if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { + error "[tcl::namespace::current]::table::configure_row error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" + } + tcl::dict::set o_rowstates $ridx -minheight $opt_minh + + + tcl::dict::set o_rowdefs $ridx $opts + } + method row_count {} { + return [tcl::dict::size $o_rowdefs] + } + method row_clear {} { + set o_rowdefs [tcl::dict::create] + set o_rowstates [tcl::dict::create] + #The data values are stored by column regardless of whether added row by row + tcl::dict::for {cidx records} $o_columndata { + tcl::dict::set o_columndata $cidx [list] + #reset only the body fields in o_columnstates + tcl::dict::set o_columnstates $cidx minwidthbodyseen 0 + tcl::dict::set o_columnstates $cidx maxwidthbodyseen 0 + } + set o_calculated_column_widths [list] + } + method clear {} { + my row_clear + set o_columndefs [tcl::dict::create] + set o_columndata [tcl::dict::create] + set o_columnstates [tcl::dict::create] + } + + + + #method Get_columns_by_name {namematch_list} { + #} + + #specify range with x..y + method Get_columns_by_indices {index_list} { + foreach spec $index_list { + if {[tcl::string::is integer -strict $c]} { + set colidx $c + } else { + tcl::dict::for {colidx coldef} $o_columndefs { + #if {[tcl::string::match x x]} {} + } + } + } + } + method Get_boxlimits_and_joins {position fname_body} { + #fname_body will be "custom" or one of the predefined types light,heavy etc + switch -- $position { + left { + return [tcl::dict::create \ + boxlimits [list hlb blc vll]\ + boxlimits_top [list hlb blc vll hlt tlc]\ + joins [list down]\ + bodyjoins [list down-$fname_body]\ + ] + } + inner { + return [tcl::dict::create \ + boxlimits [list hlb blc vll]\ + boxlimits_top [list hlb blc vll hlt tlc]\ + joins [list down left]\ + bodyjoins [list left down-$fname_body] + ] + } + right { + return [tcl::dict::create \ + boxlimits [list hlb blc vll vlr brc]\ + boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ + joins [list down left]\ + bodyjoins [list left down-$fname_body]\ + ] + } + solo { + return [tcl::dict::create \ + boxlimits [list hlb blc vll vlr brc]\ + boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ + joins [list down]\ + bodyjoins [list down-$fname_body]\ + ] + } + default { + error "Get_boxlimits_and_joins unrecognised position '$position' expected: left inner right solo" + } + } + } + method Get_boxlimits_and_joins1 {position fname_body} { + #fname_body will be "custom" or one of the predefined types light,heavy etc + switch -- $position { + left { + #set header_boxlimits {hlb hlt tlc blc vll} + set header_body_joins [list down-$fname_body] + set boxlimits_position [list hlb blc vll] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] + set boxlimits_toprow [list hlb blc vll hlt tlc] + set joins [list down] + } + inner { + #set header_boxlimits {hlb hlt tlc blc vll} + set header_body_joins [list left down-$fname_body] + set boxlimits_position [list hlb blc vll] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] + set boxlimits_toprow [list hlb blc vll hlt tlc] + set joins [list down left] + } + right { + #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} + set header_body_joins [list left down-$fname_body] + set boxlimits_position [list hlb blc vll vlr brc] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] + set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] + set joins [list down left] + } + solo { + #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} + set header_body_joins [list down-$fname_body] + set boxlimits_position [list hlb blc vll vlr brc] + #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] + set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] + set joins [list down] + } + } + return [tcl::dict::create boxlimits $boxlimits_position boxlimits_top $boxlimits_toprow joins $joins bodyjoins $header_body_joins ] + } + method get_column_by_index {index_expression args} { + #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" + #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. + set opts [tcl::dict::create\ + -position "inner"\ + -return "string"\ + ] + foreach {k v} $args { + switch -- $k { + -position - -return { + tcl::dict::set opts $k $v + } + default { + error "[tcl::namespace::current]::table::get_column_by_index error invalid option '$k'. Known options [tcl::dict::keys $opts]" + } + } + } + set opt_posn [tcl::dict::get $opts -position] + set opt_return [tcl::dict::get $opts -return] + + switch -- $opt_posn { + left - inner - right - solo {} + default { + error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_posn' for -position. Valid values: [list left inner right solo]" + } + } + switch -- $opt_return { + string - dict {} + default { + error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_return' for -return. Valid values: string dict" + } + } + + set columninfo [my get_column_cells_by_index $index_expression] + set header_list [tcl::dict::get $columninfo headers] + #puts "===== header_list: $header_list" + set cells [tcl::dict::get $columninfo cells] + + set topt_show_header [tcl::dict::get $o_opts_table -show_header] + if {$topt_show_header eq ""} { + set allheaders 0 + set all_cols [tcl::dict::keys $o_columndefs] + foreach c $all_cols { + incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] + } + if {$allheaders == 0} { + set do_show_header 0 + } else { + set do_show_header 1 + } + } else { + set do_show_header $topt_show_header + } + set topt_show_footer [tcl::dict::get $o_opts_table -show_footer] + + + set output "" + set part_header "" + set part_body "" + set part_footer "" + + set boxlimits "" + set joins "" + set header_boxlimits [list] + set header_body_joins [list] + + + set ftypes [my Get_frametypes] + set ftype_body [tcl::dict::get $ftypes body] + if {[llength $ftype_body] >= 2} { + set fname_body "custom" + } else { + set fname_body $ftype_body + } + set ftype_header [tcl::dict::get $ftypes header] + if {[llength $ftype_header] >= 2} { + set fname_header "custom" + } else { + set fname_header $ftype_header + } + + set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] + set header_body_joins [tcl::dict::get $limj bodyjoins] + set joins [tcl::dict::get $limj joins] + set boxlimits_position [tcl::dict::get $limj boxlimits] + set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] + #use struct::set instead of simple for loop - will be faster at least when critcl available + set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] + set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] + set header_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_position] + set header_boxlimits_toprow [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_toprow] + + set fmap [tcl::dict::get $o_opts_table_effective -framemap_body] + set hmap [tcl::dict::get $o_opts_table_effective -framemap_header] + + #if {![tcl::dict::get $o_opts_table -show_edge]} { + # set body_edgemap [textblock::class::table_edge_map ""] + # dict for {k v} $fmap { + # #tcl::dict::set fmap $k [tcl::dict::merge $v [tcl::dict::get $body_edgemap $k]] + # } + # set header_edgemap [textblock::class::header_edge_map ""] + # dict for {k v} $hmap { + # #tcl::dict::set hmap $k [tcl::dict::merge $v [tcl::dict::get $header_edgemap $k]] + # } + #} + set sep_elements_horizontal $::textblock::class::table_hseps + set sep_elements_vertical $::textblock::class::table_vseps + + set topmap [tcl::dict::get $fmap top$opt_posn] + set botmap [tcl::dict::get $fmap bottom$opt_posn] + set midmap [tcl::dict::get $fmap middle$opt_posn] + set onlymap [tcl::dict::get $fmap only$opt_posn] + + set hdrmap [tcl::dict::get $hmap only${opt_posn}] + + set topseps_h [tcl::dict::get $sep_elements_horizontal top$opt_posn] + set midseps_h [tcl::dict::get $sep_elements_horizontal middle$opt_posn] + set topseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] + set midseps_v [tcl::dict::get $sep_elements_vertical middle$opt_posn] + set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] + set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] + + #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway + set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] + + lassign [my Get_seps] _h show_seps_h _v show_seps_v + set return_headerheight 0 + set return_headerwidth 0 + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + + set colwidth [my column_width $cidx] + + set col_blockalign [tcl::dict::get $o_columndefs $cidx -blockalign] + + if {$do_show_header} { + #puts "boxlimitsinfo header $opt_posn: -- boxlimits $header_boxlimits -- boxmap $hdrmap" + set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure + set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] + if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { + set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] + set ansiborder_final $ansibase_header$ansiborder_header$extrabg + } else { + set ansiborder_final $ansibase_header$ansiborder_header + } + set RST [punk::ansi::a] + + + set hcolwidth $colwidth + #set hcolwidth [my column_width_configured $cidx] + set hcell_line_blank [tcl::string::repeat " " $hcolwidth] + + set all_colspans [my header_colspans_numeric] + + #put our framedef calls together + set fdef_header [textblock::framedef $ftype_header] + set framedef_leftbox [textblock::framedef -joins left $ftype_header] + set framedef_headerdown_same [textblock::framedef -joins {down} $ftype_header] + set framedef_headerdown_body [textblock::framedef -joins [list down-$fname_body] $ftype_header] + #default span_extend_map - used as base to customise with specific joins + set span_extend_map [tcl::dict::create \ + vll " "\ + tlc [tcl::dict::get $fdef_header hlt]\ + blc [tcl::dict::get $fdef_header hlb]\ + ] + + + #used for colspan-zero header frames + set framesub_map [list hl $TSUB vll $TSUB vlr $TSUB tlc $TSUB blc $TSUB trc $TSUB brc $TSUB] ;# a debug test + + set hrow 0 + set hmax [expr {[llength $header_list] -1}] + foreach header $header_list { + set headerspans [tcl::dict::get $all_colspans $hrow] + set this_span [lindex $headerspans $cidx] + set hval $ansibase_header$header ;#no reset + set rowh [my header_height $hrow] + + if {$hrow == 0} { + set hlims $header_boxlimits_toprow + set rowpos "top" + if {$hrow == $hmax} { + set rowpos "only" + } + } else { + set hlims $header_boxlimits + set rowpos "middle" + if {$hrow == $hmax} { + set rowpos "bottom" + } + } + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $headerseps_v] + } + if {$hrow == $hmax} { + set header_joins $header_body_joins + } else { + set header_joins $joins + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] + } + #puts ">>> headerspans: $headerspans cidx: $cidx" + + #if {$this_span eq "any" || $this_span > 0} {} + #changed to processing only numeric colspans + + if {$this_span > 0} { + set startmap [tcl::dict::get $hmap $rowpos${opt_posn}] + #look at spans in header below to determine joins required at blc + if {$show_seps_v} { + if {[tcl::dict::exists $all_colspans [expr {$hrow+1}]]} { + set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] + set spanbelow [lindex $next_spanlist $cidx] + if {$spanbelow == 0} { + #we don't want a down-join for blc - use a framedef with only left joins + tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] + } + } else { + set next_spanlist [list] + } + } + + #supporting wrapping in headers might be a step too difficult for little payoff. + #we would need a flag to enable/disable - plus language-based wrapping alg (see tcllib) + #The interaction with colspans and width calculations makes it likely to have a heavy performance impact and make the code even more complex. + #May be better to require user to pre-wrap as needed + ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] + + #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used + #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) + + # -width is always +2 - as the boxlimits take into account show_vseps and show_edge + #set header_cell_startspan [textblock::frame -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ + # -ansibase $ansibase_header -ansiborder $ansiborder_final\ + # -boxlimits $hlims -boxmap $startmap -joins $header_joins $hval\ + # ] + + if {$this_span == 1} { + #write the actual value now + set cellcontents $hval + } else { + #just write an empty vertical placeholder. The spanned value will be overtyped below + set cellcontents [::join [lrepeat [llength [split $hval \n]] ""] \n] + } + set header_cell_startspan [textblock::frame -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ + -ansibase $ansibase_header -ansiborder $ansiborder_final\ + -boxlimits $hlims -boxmap $startmap -joins $header_joins $cellcontents\ + ] + + if {$this_span != 1} { + #puts "===>\n$header_cell_startspan\n<===" + set spanned_parts [list $header_cell_startspan] + #assert this_span == "any" or >1 ie a header that spans other columns + #therefore more parts to append + #set remaining_cols [lrange [tcl::dict::keys $o_columndefs] $cidx end] + set remaining_spans [lrange $headerspans $cidx+1 end] + set spanval [join $remaining_spans ""] ;#so we can test for all zeros + set spans_to_rhs 0 + if {[expr {$spanval}] == 0} { + #puts stderr "SPANS TO RHS" + set spans_to_rhs 1 + } + + #puts ">> remaining_spans: $remaining_spans" + set spancol [expr {$cidx + 1}] + set h_lines [lrepeat $rowh ""] + set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow + + + + set last [expr {[llength $remaining_spans] -1}] + set i 0 + foreach s $remaining_spans { + if {$s == 0} { + if {$i == $last} { + set next_posn right + #set next_posn inner + } else { + set next_posn inner + } + + set next_headerseps_v [tcl::dict::get $sep_elements_vertical top$next_posn] ;#static top ok + + set limj [my Get_boxlimits_and_joins $next_posn $fname_body] + set span_joins_body [tcl::dict::get $limj bodyjoins] + set span_joins [tcl::dict::get $limj joins] + set span_boxlimits [tcl::dict::get $limj boxlimits] + set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] + #use struct::set instead of simple for loop - will be faster at least when critcl available + #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] + #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] + set header_span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits] + set header_span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits_top] + if {$hrow == 0} { + set hlims $header_span_boxlimits_top + } else { + set hlims $header_span_boxlimits + } + + set this_span_map $span_extend_map + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $next_headerseps_v] + } else { + if {[llength $next_spanlist]} { + set spanbelow [lindex $next_spanlist $spancol] + if {$spanbelow != 0} { + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_same hlbj] ;#horizontal line bottom with down join - to same frametype + } + } else { + #join to body + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype + } + } + + if {$hrow == $hmax} { + set header_joins $span_joins_body + } else { + set header_joins $span_joins + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] + } + + set contentwidth [my column_width $spancol] + set header_cell [textblock::frame -ellipsis 0 -width [expr {$contentwidth + 2}] -type [tcl::dict::get $ftypes header]\ + -ansibase $ansibase_header -ansiborder $ansiborder_final\ + -boxlimits $hlims -boxmap $this_span_map -joins $header_joins $hcell_blank\ + ] + lappend spanned_parts $header_cell + } else { + break + } + incr spancol + incr i + } + + #JMN + #spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic + set spanned_frame [textblock::join_basic -- {*}$spanned_parts] + + if {$spans_to_rhs} { + if {$cidx == 0} { + set fake_posn solo + } else { + set fake_posn right + } + set x_limj [my Get_boxlimits_and_joins $fake_posn $fname_body] + if {$hrow == 0} { + set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] + set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] + } else { + set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] + set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] + } + } else { + if {$hrow == 0} { + set hlims $header_boxlimits_toprow + } else { + set hlims $header_boxlimits + } + } + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $headerseps_v] + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + if {$spans_to_rhs} { + #assert fake_posn has been set above based on cidx and spans_to_rhs + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts ${rowpos}$fake_posn] ] + } else { + #use the edge_parts corresponding to the column being written to ie use opt_posn + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] + } + } + + set spacemap [list hl " " vl " " tlc " " blc " " trc " " brc " "] ;#transparent overlay elements + #set spacemap [list hl * vl * tlc * blc * trc * brc *] + #-usecache 1 ok + #hval is not raw headerval - it has been padded to required width and has ansi applied + set hblock [textblock::frame -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase + #puts "==>boxlimits:'$hlims' hval_width:[tcl::string::length $hval] blockwidth:[textblock::width $hblock]" + #puts $hblock + #puts "==>hval:'$hval'[a]" + #puts "==>hval:'[ansistring VIEW $hval]'" + #set spanned_frame [overtype::renderspace -transparent 1 $spanned_frame $hblock] + + #spanned values default left - todo make configurable + + #TODO + #consider that currently blockaligning for spanned columns must always use the blockalign value from the starting column of the span + #we could conceivably have an override that could be set somehow with configure_header for customization of alignments of individual spans or span sizes? + #this seems like a likely requirement. The first spanned column may well have different alignment requirements than the span. + #(e.g if first spanned col happens to be numeric it probably warrants right textalign (if not blockalign) but we don't necessarily want the spanning header or even a non-spanning header to be right aligned) + + set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] + #POTENTIAL BUG (fixed with spans_to_rhs above) + #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) + #we need to shift 1 to the left when doing our overtype with blockalign right + #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge + #(even though the column position may be left or inner) + + + + } else { + #this_span == 1 + set spanned_frame [textblock::join_basic -- $header_cell_startspan] + } + + + append part_header $spanned_frame + append part_header \n + } else { + #zero span header directly in this column ie one that is being colspanned by some column to our left + #previous col will already have built lines for this in it's own header rhs overhang + #we need a block of TSUB chars of the right height and width in this column so that we can join this column to the left ones with the TSUBs being transparent. + + #set padwidth [my column_datawidth $cidx -headers 0 -data 1 -cached 1] + + #if there are no header elements above then we will need a minimum of the column width + #may be extended to the widest portion of the header in the loop below + set padwidth [my column_width $cidx] + + + #under assumption we are building table using L frame method and that horizontal borders are only ever 1 high + # - we can avoid using a frame - but we potentially need to manually adjust for show_hpos show_edge etc + #avoiding frame here is faster.. but not by much (<10%? on textblock::spantest2 ) + if 0 { + #breaks -show_edge 0 + if {$rowpos eq "top" && [tcl::dict::get $o_opts_table -show_edge]} { + set padheight [expr {$rowh + 2}] + } else { + set padheight [expr {$rowh + 1}] + } + set bline [tcl::string::repeat $TSUB [expr {$padwidth +1}]] + set h_lines [lrepeat $padheight $bline] + set hcell_blank [::join $h_lines \n] + set header_frame $hcell_blank + } else { + set bline [tcl::string::repeat $TSUB $padwidth] + set h_lines [lrepeat $rowh $bline] + set hcell_blank [::join $h_lines \n] + # -usecache 1 ok + #frame borders will never display - so use the simplest frametype and don't apply any ansi + #puts "===>zerospan hlims: $hlims" + set header_frame [textblock::frame -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ + -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ + ] + } + + append part_header $header_frame\n + + } + incr hrow + } + if {![llength $header_list]} { + #no headers - but we've been asked to show_header + #display a zero content-height header (ie outline if edge is being shown - or bottom bar) + set hlims $header_boxlimits_toprow + if {!$show_seps_v} { + set hlims [struct::set difference $hlims $headerseps_v] + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts only$opt_posn] ] + } + set header_joins $header_body_joins + set header_frame [textblock::frame -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ + -ansibase $ansibase_header -ansiborder $ansiborder_final\ + -boxlimits $hlims -boxmap $hdrmap -joins $header_joins\ + ] + append part_header $header_frame\n + } + set part_header [tcl::string::trimright $part_header \n] + lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight + + set padline [tcl::string::repeat $TSUB $return_headerwidth] + set adjusted_lines [list] + foreach ln [split $part_header \n] { + if {[tcl::string::first $TSUB $ln] >=0} { + lappend adjusted_lines $padline + } else { + lappend adjusted_lines $ln + } + } + set part_header [::join $adjusted_lines \n] + #append output $part_header \n + } + + set r 0 + set rmax [expr {[llength $cells]-1}] + + + set blims_mid $boxlimits + set blims_top $boxlimits + set blims_bot $boxlimits + set blims_top_headerless $boxlimits_headerless + set blims_only $boxlimits + set blims_only_headerless $boxlimits_headerless + if {!$show_seps_h} { + set blims_mid [struct::set difference $blims_mid $midseps_h] + set blims_top [struct::set difference $blims_top $topseps_h] + set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_h] + } + if {!$show_seps_v} { + set blims_mid [struct::set difference $blims_mid $midseps_v] + set blims_top [struct::set difference $blims_top $topseps_v] + set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_v] + set blims_bot [struct::set difference $blims_bot $botseps_v] + set blims_only [struct::set difference $blims_only $onlyseps_v] + set blims_only_headerless [struct::set difference $blims_only_headerless $onlyseps_v] + } + + set colidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] ;#convert possible end-1,2+2 etc expression to >= 0 integer in dict range + + set opt_col_ansibase [tcl::dict::get $o_columndefs $colidx -ansibase] ;#ordinary merge of codes already done in configure_column + #set colwidth [my column_width $colidx] + + set body_ansibase [tcl::dict::get $o_opts_table -ansibase_body] + #set ansibase [punk::ansi::codetype::sgr_merge_singles [list $body_ansibase $opt_col_ansibase]] ;#allow col to override body + set body_ansiborder [tcl::dict::get $o_opts_table -ansiborder_body] + if {[tcl::dict::get $o_opts_table -frametype] eq "block"} { + #block is the only style where bg colour can fill the frame content area exactly if the L-shaped border elements are styled + #we need to only accept background ansi codes from the columndef ansibase for this + set col_bg [punk::ansi::codetype::sgr_merge_singles [list $opt_col_ansibase] -filter_fg 1] ;#special merge for block borders - don't override fg colours + set border_ansi $body_ansibase$body_ansiborder$col_bg + } else { + set border_ansi $body_ansibase$body_ansiborder + } + + + set r 0 + set ftblock [expr {[tcl::dict::get $o_opts_table -frametype] eq "block"}] + foreach c $cells { + #cells in column - each new c is in a different row + set row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] + set row_bg "" + if {$row_ansibase ne ""} { + set row_bg [punk::ansi::codetype::sgr_merge_singles [list $row_ansibase] -filter_fg 1] + } + + set ansibase $body_ansibase$opt_col_ansibase + #todo - joinleft,joinright,joindown based on opts in args + set cell_ansibase "" + + set ansiborder_body_col_row $border_ansi$row_bg + set ansiborder_final $ansiborder_body_col_row + #$c will always have ansi resets due to overtype behaviour ? + #todo - review overtype + if {[punk::ansi::ta::detect $c]} { + #use only the last ansi sequence in the cell value + #Filter out foreground and use background for ansiborder override + set parts [punk::ansi::ta::split_codes_single $c] + #we have detected ansi - so there will always be at least 3 parts beginning and ending with pt pt,ansi,pt,ansi...,pt + set codes [list] + foreach {pt cd} $parts { + if {$cd ne ""} { + lappend codes $cd + } + } + #set takebg [lindex $parts end-1] + #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] + set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] + #puts --->[ansistring VIEW $codes] + + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { + #special case double reset at end of content + set cell_ansi_tail [punk::ansi::codetype::sgr_merge_singles $codes] ;#no filters + set ansibase "" + set row_ansibase "" + if {$ftblock} { + set ansiborder_final [punk::ansi::codetype::sgr_merge [list $ansiborder_body_col_row] -filter_bg 1] + } + set cell_ansibase $cell_ansi_tail + } else { + #single trailing reset in content + set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase + } + } else { + if {$ftblock} { + #no resets - use cell's bg to extend to the border - only for block frames + set ansiborder_final $ansiborder_body_col_row$cell_bg + } + set cell_ansibase $cell_bg + } + } + + set ansibase_final $ansibase$row_ansibase$cell_ansibase + + if {$r == 0} { + if {$r == $rmax} { + set joins [lremove $joins [lsearch $joins down*]] + set bmap $onlymap + if {$do_show_header} { + set blims $blims_only + } else { + set blims $blims_only_headerless + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] + } + } else { + set bmap $topmap + if {$do_show_header} { + set blims $blims_top + } else { + set blims $blims_top_headerless + } + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts top$opt_posn] ] + } + } + set rowframe [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c] + set return_bodywidth [textblock::widthtopline $rowframe] ;#frame lines always same width - just look at top line + append part_body $rowframe \n + } else { + if {$r == $rmax} { + set joins [lremove $joins [lsearch $joins down*]] + set bmap $botmap + set blims $blims_bot + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts bottom$opt_posn] ] + } + } else { + set bmap $midmap + set blims $blims_mid ;#will only be reduced from boxlimits if -show_seps was processed above + if {![tcl::dict::get $o_opts_table -show_edge]} { + set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts middle$opt_posn] ] + } + } + append part_body [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n + } + incr r + } + #return empty (zero content height) row if no rows + if {![llength $cells]} { + set joins [lremove $joins [lsearch $joins down*]] + #we need to know the width of the column to setup the empty cell properly + #even if no header displayed - we should take account of any defined column widths + set colwidth [my column_width $index_expression] + + if {$do_show_header} { + set blims $blims_only + } else { + append part_body \n + set blims $blims_only_headerless + } + #note that if show_edge is 0 - then for this empty line - we will not expect to see any bars + #This is because the frame with no data had vertical components made entirely of corner elements + #we could just append a newline when -show_edge is zero, but we want the correct width even when empty - for proper column joins when there are colspanned headers. + # + if {![tcl::dict::get $o_opts_table -show_edge]} { + #set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] + #append output [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins]\n + append part_body [tcl::string::repeat " " $colwidth] \n + set return_bodywidth $colwidth + } else { + set emptyframe [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins] + append part_body $emptyframe \n + set return_bodywidth [textblock::width $emptyframe] + } + } + #assert bodywidth is integer >=0 whether there are rows or not + + #trim only 1 newline + if {[tcl::string::index $part_body end] eq "\n"} { + set part_body [tcl::string::range $part_body 0 end-1] + } + set return_bodyheight [textblock::height $part_body] + #append output $part_body + + if {$opt_return eq "string"} { + if {$part_header ne ""} { + set output $part_header + if {$part_body ne ""} { + append output \n $part_body + } + } else { + set output $part_body + } + return $output + } else { + return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] + } + } + + method get_column_cells_by_index {index_expression} { + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + set range "" + if {[tcl::dict::size $o_columndefs] > 0} { + set range "0..[expr {[tcl::dict::size $o_columndefs] -1}]" + } else { + set range empty + } + error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" + } + #assert cidx is integer >=0 + set num_header_rows [my header_count] + set cdef [tcl::dict::get $o_columndefs $cidx] + set headerlist [tcl::dict::get $cdef -headers] + set ansibase_col [tcl::dict::get $cdef -ansibase] + set textalign [tcl::dict::get $cdef -textalign] + switch -- $textalign { + left {set pad right} + right {set pad left} + default { + set pad "centre" ;#todo? + } + } + + set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body] + set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] + + #set header_underlay $ansibase_header$cell_line_blank + + #set hdrwidth [my column_width_configured $cidx] + #set all_colspans [my header_colspans] + #we need to replace the 'any' entries with their actual span lengths before passing any -colspan values to column_datawidth - hence use header_colspans_numeric + set all_colspans [my header_colspans_numeric] + #JMN + #store configured widths so we don't look up for each header line + #set configured_widths [list] + #foreach c [tcl::dict::keys $o_columndefs] { + # #lappend configured_widths [my column_width $c] + # #we don't just want the width of the column in the body - or the headers will get truncated + # lappend configured_widths [my column_width_configured $c] + #} + + set output [tcl::dict::create] + tcl::dict::set output headers [list] + + set showing_vseps [my Showing_vseps] + for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} { + set hdr [lindex $headerlist $hrow] + set header_maxdataheight [my header_height $hrow] ;#from cached headerstates + set headerrow_colspans [tcl::dict::get $all_colspans $hrow] + set this_span [lindex $headerrow_colspans $cidx] + + #set this_hdrwidth [lindex $configured_widths $cidx] + set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign + + set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] + set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] + set hval_lines [split $hdr \n] + set hval_lines [concat $hval_lines $hcell_lines] + set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top + set hval_block [::join $hval_lines \n] + set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] + tcl::dict::lappend output headers $hcell + } + + + #set colwidth [my column_width $cidx] + #set cell_line_blank [tcl::string::repeat " " $colwidth] + set datawidth [my column_datawidth $cidx -headers 0 -footers 0 -data 1 -cached 1] + set cell_line_blank [tcl::string::repeat " " $datawidth] + + + + set items [tcl::dict::get $o_columndata $cidx] + #puts "---> columndata $o_columndata" + + #set opt_row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] + #set cell_ansibase $ansibase_body$ansibase_col$opt_row_ansibase + + tcl::dict::set output cells [list];#ensure we return something for cells key if no items in list + set r 0 + foreach cval $items { + #todo move to row_height method ? + set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] + set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] + set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] + if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { + #an exact height is defined for the row + set rowh $rowdefminh + } else { + if {$rowdefminh eq ""} { + if {$rowdefmaxh eq ""} { + #both defs empty + set rowh $maxdataheight + } else { + set rowh [expr {min(1,$rowdefmaxh,$maxdataheight)}] + } + } else { + if {$rowdefmaxh eq ""} { + set rowh [expr {max($rowdefminh,$maxdataheight)}] + } else { + if {$maxdataheight < $rowdefminh} { + set rowh $rowdefminh + } else { + set rowh [expr {max($rowdefminh,$maxdataheight)}] + } + } + } + } + + set cell_lines [lrepeat $rowh $cell_line_blank] + #set cell_blank [join $cell_lines \n] + + + set cval_lines [split $cval \n] + set cval_lines [concat $cval_lines $cell_lines] + set cval_lines [lrange $cval_lines 0 $rowh-1] + set cval_block [::join $cval_lines \n] + + + set cell [textblock::pad $cval_block -width $datawidth -padchar " " -within_ansi 1 -which $pad] + #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] + tcl::dict::lappend output cells $cell + + incr r + } + return $output + } + method get_column_values_by_index {index_expression} { + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + return [tcl::dict::get $o_columndata $cidx] + } + method debug {args} { + #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) + set defaults [tcl::dict::create\ + -usetables 1\ + ] + foreach {k v} $args { + switch -- $k { + -usetables {} + default { + error "table debug unrecognised option '$k'. Known options: [tcl::dict::keys $defaults]" + } + } + } + set opts [tcl::dict::merge $defaults $args] + set opt_usetables [tcl::dict::get $opts -usetables] + + puts stdout "rowdefs: $o_rowdefs" + puts stdout "rowstates: $o_rowstates" + #puts stdout "columndefs: $o_columndefs" + puts stdout "columndefs:" + if {!$opt_usetables} { + tcl::dict::for {k v} $o_columndefs { + puts " $k $v" + } + } else { + set t [textblock::class::table new] + $t add_column -headers "Col" + tcl::dict::for {col coldef} $o_columndefs { + foreach property [tcl::dict::keys $coldef] { + if {$property eq "-ansireset"} { + continue + } + $t add_column -headers $property + } + break + } + + #build our inner tables first so we can sync widths + set col_header_tables [tcl::dict::create] + set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths + tcl::dict::for {col coldef} $o_columndefs { + set row [list $col] + set colheaders [tcl::dict::get $coldef -headers] + #inner table probably overkill here ..but just as easy + set htable [textblock::class::table new] + $htable configure -show_header 1 -show_edge 0 -show_hseps 0 + $htable add_column -headers row + $htable add_column -headers text + $htable add_column -headers WxH + $htable add_column -headers span + set hnum 0 + set spans [tcl::dict::get $o_columndefs $col -header_colspans] + foreach h $colheaders s $spans { + lassign [textblock::size $h] _w width _h height + $htable add_row [list "$hnum " $h "${width}x${height}" $s] + incr hnum + } + $htable configure_column 0 -ansibase [a+ web-dimgray] + tcl::dict::set col_header_tables $col $htable + set colwidths [$htable column_widths] + set icol 0 + foreach w $colwidths { + if {$w > [tcl::dict::get $max_widths $icol]} { + tcl::dict::set max_widths $icol $w + } + incr icol + } + } + + #safe jumptable test + #dict for {col coldef} $o_columndefs {} + tcl::dict::for {col coldef} $o_columndefs { + set row [list $col] + #safe jumptable test + #dict for {property val} $coldef {} + tcl::dict::for {property val} $coldef { + switch -- $property { + -ansireset {continue} + -headers { + set htable [tcl::dict::get $col_header_tables $col] + tcl::dict::for {innercol maxw} $max_widths { + $htable configure_column $innercol -minwidth $maxw -blockalign left + } + lappend row [$htable print] + $htable destroy + } + default { + lappend row $val + } + } + } + $t add_row $row + } + + + + + $t configure -show_header 1 + puts stdout [$t print] + $t destroy + } + puts stdout "columnstates: $o_columnstates" + puts stdout "headerstates: $o_headerstates" + tcl::dict::for {k coldef} $o_columndefs { + if {[tcl::dict::exists $o_columndata $k]} { + set headerlist [tcl::dict::get $coldef -headers] + set coldata [tcl::dict::get $o_columndata $k] + set colinfo "rowcount: [llength $coldata]" + set allfields [concat $headerlist $coldata] + if {[llength $allfields]} { + set widest [tcl::mathfunc::max {*}[lmap v $allfields {textblock::width $v}]] + } else { + set widest 0 + } + append colinfo " widest of headers and data: $widest" + } else { + set colinfo "WARNING - no columndata record for column key '$k'" + } + puts stdout "column $k columndata info: $colinfo" + } + set result "" + set cols [list] + set max [expr {[tcl::dict::size $o_columndefs]-1}] + foreach c [tcl::dict::keys $o_columndefs] { + if {$c == 0} { + lappend cols [my get_column_by_index $c -position left] " " + } elseif {$c == $max} { + lappend cols [my get_column_by_index $c -position right] + } else { + lappend cols [my get_column_by_index $c -position inner] " " + } + } + append result [textblock::join -- {*}$cols] + return $result + } + #column width including headers - but without colspan consideration + method column_width_configured {index_expression} { + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + #assert cidx is now >=0 integer within the range of defined columns + set cdef [tcl::dict::get $o_columndefs $cidx] + set defminw [tcl::dict::get $cdef -minwidth] + set defmaxw [tcl::dict::get $cdef -maxwidth] + if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { + #an exact width is defined for the column - no need to look at data width + set colwidth $defminw + } else { + #set widest [my column_datawidth $cidx -headers 1 -data 1 -footers 1] + set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] + #set hwidest [my column_datawidth $cidx -headers 1 -colspan 1 -data 0 -footers 1] + #set hwidest_singlespan ?? + set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] + set widest [expr {max($hwidest,$bwidest)}] + #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. + #if so - a truncated line shouldn't be included in our width calculation + if {$defminw eq ""} { + if {$defmaxw eq ""} { + set colwidth $widest + } else { + set colwidth [expr {min($defmaxw,$widest)}] + } + } else { + if {$defmaxw eq ""} { + set colwidth [expr {max($defminw,$widest)}] + } else { + if {$widest < $defminw} { + set colwidth $defminw + } else { + if {$widest > $defmaxw} { + set colwidth $defmaxw + } else { + set colwidth [expr {max($defminw,$widest)}] + } + } + } + } + } + return $colwidth + } + + method column_width {index_expression} { + if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { + my calculate_column_widths -algorithm $o_column_width_algorithm + } + return [lindex $o_calculated_column_widths $index_expression] + } + method column_widths {} { + if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { + my calculate_column_widths -algorithm $o_column_width_algorithm + } + return $o_calculated_column_widths + } + + #width of a table includes borders and seps + #whereas width of a column refers to the borderless width (inner width) + method width {} { + #calculate width based on assumption frame verticals are 1-wide - review - what about custom unicode double-wide frame? + set colwidths [my column_widths] + set contentwidth [tcl::mathop::+ {*}$colwidths] + set twidth $contentwidth + if {[my Showing_vseps]} { + incr twidth [llength $colwidths] + incr twidth -1 + } + if {[tcl::dict::get $o_opts_table -show_edge]} { + incr twidth 2 + } + return $twidth + } + + #column *body* content width + method basic_column_width {index_expression} { + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + #puts "===column_width $index_expression" + #assert cidx is now >=0 integer within the range of defined columns + set cdef [tcl::dict::get $o_columndefs $cidx] + set defminw [tcl::dict::get $cdef -minwidth] + set defmaxw [tcl::dict::get $cdef -maxwidth] + if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { + #an exact width is defined for the column - no need to look at data width + #review - this can result in truncation of spanning headers - even though there is enough width in the span-cell to place the full header + set colwidth $defminw + } else { + #set widest [my column_datawidth $cidx -headers 0 -data 1 -footers 0] + set widest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] + #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. + #if so - a truncated line shouldn't be included in our width calculation + if {$defminw eq ""} { + if {$defmaxw eq ""} { + set colwidth $widest + } else { + set colwidth [expr {min($defmaxw,$widest)}] + } + } else { + if {$defmaxw eq ""} { + set colwidth [expr {max($defminw,$widest)}] + } else { + if {$widest < $defminw} { + set colwidth $defminw + } else { + if {$widest > $defmaxw} { + set colwidth $defmaxw + } else { + set colwidth [expr {max($defminw,$widest)}] + } + } + } + } + } + set configured_widths [list] + foreach c [tcl::dict::keys $o_columndefs] { + lappend configured_widths [my column_width_configured $c] + } + set header_colspans [my header_colspans] + set width_max $colwidth + set test_width $colwidth + set showing_vseps [my Showing_vseps] + set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] + tcl::dict::for {h colspans} $header_colspans { + set spanc [lindex $colspans $cidx] + #set headers [tcl::dict::get $cdef -headers] + #set thiscol_widest_header 0 + #if {[llength $headers] > 0} { + # set thiscol_widest_header [tcl::mathfunc::max {*}[lmap v $headers {textblock::width $v}]] + #} + if {$spanc eq "1"} { + if {$thiscol_widest_header > $colwidth} { + set test_width [expr {max($thiscol_widest_header,$colwidth)}] + if {$defmaxw ne ""} { + set test_width [expr {min($colwidth,$defmaxw)}] + } + } + set width_max [expr {max($test_width,$width_max)}] + continue + } + if {$spanc eq "any" || $spanc > 1} { + set spanned [list] ;#spanned is other columns spanned - not including this one + set cnext [expr {$cidx +1}] + set spanlength [lindex $colspans $cnext] + while {$spanlength eq "0" && $cnext < [llength $colspans]} { + lappend spanned $cnext + incr cnext + set spanlength [lindex $colspans $cnext] + } + set others_width 0 + foreach col $spanned { + incr others_width [lindex $configured_widths $col] + if {$showing_vseps} { + incr others_width 1 + } + } + set total_spanned_width [expr {$width_max + $others_width}] + if {$thiscol_widest_header > $total_spanned_width} { + #this just allocates the extra space in the current column - which is not great. + #A proper algorithm for distributing width created by headers to all the spanned columns is needed. + #This is a tricky problem with multiple header lines and arbitrary spans. + #The calculation should probably be done on the table as a whole first and this function should just look up that result. + #Trying to calculate on a specific column only is unlikely to be easy or efficient. + set needed [expr {$thiscol_widest_header - $total_spanned_width}] + #puts "-->>col $cidx needed ($thiscol_widest_header - $total_spanned_width): $needed (spanned $spanned)" + if {$defmaxw ne ""} { + set test_width [expr {min($colwidth+$needed,$defmaxw)}] + } else { + set test_width [expr {$colwidth + $needed}] + } + } + } + set width_max [expr {max($test_width,$width_max)}] + } + + #alternative to all the above shennanigans.. let the body cell data determine the size and just wrap the headers + #could also split the needed width amongst the spanned columns? configurable for whether cells expand? + set expand_first_column 1 + if {$expand_first_column} { + set colwidth $width_max + } + + #puts "---column_width $cidx = $colwidth" + return $colwidth + } + method Showing_vseps {} { + #review - show_seps and override mechanism for show_vseps show_hseps - document. + set seps [tcl::dict::get $o_opts_table -show_seps] + set vseps [tcl::dict::get $o_opts_table -show_vseps] + if {$seps eq ""} { + if {$vseps eq "" || $vseps} { + return true + } + } elseif {$seps} { + if {$vseps eq "" || $vseps} { + return true + } + } else { + if {$vseps ne "" && $vseps} { + return true + } + } + return false + } + + method column_datawidth {index_expression args} { + set opts [tcl::dict::create\ + -headers 0\ + -footers 0\ + -colspan unspecified\ + -data 1\ + -cached 1\ + ] + #NOTE: -colspan any is not the same as * + # + #-colspan is relevant to header/footer data only + foreach {k v} $args { + switch -- $k { + -headers - -footers - -colspan - -data - -cached { + tcl::dict::set opts $k $v + } + default { + error "column_datawidth unrecognised flag '$k'. Known flags: [tcl::dict::keys $opts]" + } + } + } + set opt_colspan [tcl::dict::get $opts -colspan] + switch -- $opt_colspan { + * - unspecified {} + any { + error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0 (use header_colspans_numeric to get actual spans)" + } + default { + if {![string is integer -strict $opt_colspan]} { + error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0" + } + } + } + + + set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] + if {$cidx eq ""} { + return + } + + if {[tcl::dict::get $opts -cached]} { + set hwidest 0 + set bwidest 0 + set fwidest 0 + if {[tcl::dict::get $opts -headers]} { + if {$opt_colspan in {* unspecified}} { + set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] + } else { + #this is not cached + # -- --- --- --- + set colheaders [tcl::dict::get $o_columndefs $cidx -headers] + set all_colspans_by_header [my header_colspans_numeric] + set hlist [list] + tcl::dict::for {hrow cspans} $all_colspans_by_header { + set s [lindex $cspans $cidx] + if {$s eq $opt_colspan} { + lappend hlist [lindex $colheaders $hrow] + } + } + if {[llength $hlist]} { + set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] + } else { + set hwidest 0 + } + # -- --- --- --- + } + } + if {[tcl::dict::get $opts -data]} { + set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] + } + if {[tcl::dict::get $opts -footers]} { + #TODO! + #set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthfooterseen] + } + return [expr {max($hwidest,$bwidest,$fwidest)}] + } + + #assert cidx is >=0 integer in valid range of keys for o_columndefs + set values [list] + set hwidest 0 + if {[tcl::dict::get $opts -headers]} { + if {$opt_colspan in {* unspecified}} { + lappend values {*}[tcl::dict::get $o_columndefs $cidx -headers] + } else { + # -- --- --- --- + set colheaders [tcl::dict::get $o_columndefs $cidx -headers] + set all_colspans_by_header [my header_colspans_numeric] + set hlist [list] + tcl::dict::for {hrow cspans} $all_colspans_by_header { + set s [lindex $cspans $cidx] + if {$s eq $opt_colspan} { + lappend hlist [lindex $colheaders $hrow] + } + } + if {[llength $hlist]} { + set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] + } else { + set hwidest 0 + } + # -- --- --- --- + } + } + if {[tcl::dict::get $opts -data]} { + if {[tcl::dict::exists $o_columndata $cidx]} { + lappend values {*}[tcl::dict::get $o_columndata $cidx] + } + } + if {[tcl::dict::get $opts -footers]} { + lappend values {*}[tcl::dict::get $o_columndefs $cidx -footers] + } + if {[llength $values]} { + set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] + set widest [expr {max($valwidest,$hwidest)}] + } else { + set widest $hwidest + } + return $widest + } + #print1 uses basic column joining - useful for testing/debug especially with colspans + method print1 {args} { + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0 } + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set blocks [list] + set colposn 0 + set numposns [llength $cols] + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + lappend blocks [my get_column_by_index $c {*}$flags] + incr colposn + } + if {[llength $blocks]} { + return [textblock::join -- {*}$blocks] + } else { + return "No columns matched" + } + } + method columncalc_spans {allocmethod} { + set colwidths [tcl::dict::create] ;# to use tcl::dict::incr + set colspace_added [tcl::dict::create] + + set ordered_spans [tcl::dict::create] + tcl::dict::for {col spandata} [my spangroups] { + set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] + set minwidth [tcl::dict::get $o_columndefs $col -minwidth] + set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] + if {$minwidth ne ""} { + if {$dwidth < $minwidth} { + set dwidth $minwidth + } + } + if {$maxwidth ne ""} { + if {$dwidth > $maxwidth} { + set dwidth $maxwidth + } + } + tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered + tcl::dict::set colspace_added $col 0 + + set spanlengths [tcl::dict::get $spandata spanlengths] + foreach slen $spanlengths { + set spans [tcl::dict::get $spandata spangroups $slen] + set spans [lsort -index 7 -integer $spans] + foreach s $spans { + set hwidth [tcl::dict::get $s headerwidth] + set hrow [tcl::dict::get $s hrow] + set scol [tcl::dict::get $s startcol] + tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth + tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth + } + } + } + + #safe jumptable test + #dict for {spanid spandata} $ordered_spans {} + tcl::dict::for {spanid spandata} $ordered_spans { + lassign [split $spanid ,] startcol hrow + set memcols [tcl::dict::get $spandata membercols] ;#dict with col and initial width - we ignore initial width, it's there in case we want to allocate space based on initial data width ratios + set colids [tcl::dict::keys $memcols] + set hwidth [tcl::dict::get $spandata headerwidth] + set num_cols_spanned [tcl::dict::size $memcols] + if {$num_cols_spanned == 1} { + set col [lindex $memcols 0] + set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] + if {$space_to_alloc > 0} { + set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] + if {$maxwidth ne ""} { + if {$maxwidth > [tcl::dict::get $colwidths $col]} { + set can_alloc [expr {$maxwidth - [tcl::dict::get $colwidths $col]}] + } else { + set can_alloc 0 + } + set will_alloc [expr {min($space_to_alloc,$can_alloc)}] + } else { + set will_alloc $space_to_alloc + } + if {$will_alloc} { + #tcl::dict::set colwidths $col $hwidth + tcl::dict::incr colwidths $col $will_alloc + tcl::dict::set colspace_added $col $will_alloc + } + #log! + #if {$will_alloc < $space_to_alloc} { + # #todo - debug only + # puts stderr "max width $maxwidth hit for col $col - cannot allocate extra [expr {$space_to_alloc - $will_alloc}]" + #} + } + } elseif {$num_cols_spanned > 1} { + set spannedwidth 0 + foreach col $colids { + incr spannedwidth [tcl::dict::get $colwidths $col] + } + set space_to_alloc [expr {$hwidth - $spannedwidth}] + if {[my Showing_vseps]} { + set sepcount [expr {$num_cols_spanned -1}] + incr space_to_alloc -$sepcount + } + #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added + switch -- $allocmethod { + least { + #add to least-expanded each time + #safer than method 1 - pretty balanced + if {$space_to_alloc > 0} { + for {set i 0} {$i < $space_to_alloc} {incr i} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] + foreach testcolid $ordered_all_colids { + if {$testcolid in $colids} { + #assert - we will always find a match + set colid $testcolid + break + } + } + tcl::dict::incr colwidths $colid + tcl::dict::incr colspace_added $colid + } + } + } + least_unmaxed { + #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth + #(we should be able to collapse column width to zero and have header colspans gracefully respond) + #add to least-expanded each time + #safer than method 1 - pretty balanced + if {$space_to_alloc > 0} { + for {set i 0} {$i < $space_to_alloc} {incr i} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] + set colid "" + foreach testcolid $ordered_all_colids { + set maxwidth [tcl::dict::get $o_columndefs $testcolid -maxwidth] + set can_alloc [expr {$maxwidth eq "" || $maxwidth > [tcl::dict::get $colwidths $testcolid]}] + if {$testcolid in $colids} { + if {$can_alloc} { + set colid $testcolid + break + } else { + #remove from future consideration in for loop + #log! + #puts stderr "max width $maxwidth hit for col $testcolid" + tcl::dict::unset colspace_added $testcolid + } + } + } + if {$colid ne ""} { + tcl::dict::incr colwidths $colid + tcl::dict::incr colspace_added $colid + } + } + } + } + all { + #adds space to all columns - not just those spanned - risk of underallocating and truncating some headers! + #probably not a good idea for tables with complex headers and spans + while {$space_to_alloc > 0} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_colids [tcl::dict::keys $ordered_colspace_added] + + foreach col $ordered_colids { + tcl::dict::incr colwidths $col + tcl::dict::incr colspace_added $col + incr space_to_alloc -1 + if {$space_to_alloc == 0} { + break + } + } + } + + } + } + } + } + + set column_widths [tcl::dict::values $colwidths] + #todo - -maxwidth etc + set table_minwidth [tcl::dict::get $o_opts_table -minwidth] ;#min width including frame elements + if {[tcl::string::is integer -strict $table_minwidth]} { + set contentwidth [tcl::mathop::+ {*}$column_widths] + set twidth $contentwidth + if {[my Showing_vseps]} { + incr twidth [llength $column_widths] + incr twidth -1 + } + if {[tcl::dict::get $o_opts_table -show_edge]} { + incr twidth 2 + } + # + set shortfall [expr {$table_minwidth - $twidth}] + if {$shortfall > 0} { + set space_to_alloc $shortfall + while {$space_to_alloc > 0} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_colids [tcl::dict::keys $ordered_colspace_added] + + foreach col $ordered_colids { + tcl::dict::incr colwidths $col + tcl::dict::incr colspace_added $col + incr space_to_alloc -1 + if {$space_to_alloc == 0} { + break + } + } + } + set column_widths [tcl::dict::values $colwidths] + } + + } + + return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] + } + + #spangroups keyed by column + method spangroups {} { + set column_count [tcl::dict::size $o_columndefs] + set spangroups [tcl::dict::create] + set headerwidths [tcl::dict::create] ;#key on col,hrow + foreach c [tcl::dict::keys $o_columndefs] { + tcl::dict::set spangroups $c [list spanlengths {}] + set spanlist [my column_get_spaninfo $c] + set index_spanlen_val 5 + set spanlist [lsort -index $index_spanlen_val -integer $spanlist] + set ungrouped $spanlist + + while {[llength $ungrouped]} { + set spanlen [lindex $ungrouped 0 $index_spanlen_val] + set spangroup_posns [lsearch -all -index $index_spanlen_val $ungrouped $spanlen] + set sgroup [list] + foreach p $spangroup_posns { + set spaninfo [lindex $ungrouped $p] + set hcol [tcl::dict::get $spaninfo startcol] + set hrow [tcl::dict::get $spaninfo hrow] + set header [lindex [tcl::dict::get $o_columndefs $hcol -headers] $hrow] + if {[tcl::dict::exists $headerwidths $hcol,$hrow]} { + set hwidth [tcl::dict::get $headerwidths $hcol,$hrow] + } else { + set hwidth [textblock::width $header] + tcl::dict::set headerwidths $hcol,$hrow $hwidth + } + lappend spaninfo headerwidth $hwidth + lappend sgroup $spaninfo + } + set spanlengths [tcl::dict::get $spangroups $c spanlengths] + lappend spanlengths $spanlen + tcl::dict::set spangroups $c spanlengths $spanlengths + tcl::dict::set spangroups $c spangroups $spanlen $sgroup + set ungrouped [lremove $ungrouped {*}$spangroup_posns] + } + } + return $spangroups + } + method column_get_own_spans {cidx} { + set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] + } + method column_get_spaninfo {cidx} { + set spans_by_header [my header_colspans] + set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] + set spaninfo [list] + set numcols [tcl::dict::size $o_columndefs] + #note that 'any' can occur in positions other than column 0 - meaning any remaining until next non-zero span + tcl::dict::for {hrow rawspans} $spans_by_header { + set thiscol_spanval [lindex $rawspans $cidx] + if {$thiscol_spanval eq "any" || $thiscol_spanval > 0} { + set spanstartcol $cidx ;#own column + if {$thiscol_spanval eq "any"} { + #scan right to first non-zero to get actual length of 'any' span + #REVIEW! + set spanlen 1 + for {set i [expr {$cidx+1}]} {$i < $numcols} {incr i} { + #abort at next any or number or empty string + if {[lindex $rawspans $i] ne "0"} { + break + } + incr spanlen + } + #set spanlen [expr {$numcols - $cidx}] + } else { + set spanlen $thiscol_spanval + } + } else { + #look left til we see an any or a non-zero value + for {set i $cidx} {$i > -1} {incr i -1} { + set s [lindex $rawspans $i] + if {$s eq "any" || $s > 0} { + set spanstartcol $i + if {$s eq "any"} { + #REVIEW! + #set spanlen [expr {$numcols - $i}] + set spanlen 1 + #now scan right to see how long the 'any' actually is + for {set j [expr {$i+1}]} {$j < $numcols} {incr j} { + if {[lindex $rawspans $j] ne "0"} { + break + } + incr spanlen + } + } else { + set spanlen $s + } + break + } + } + } + #assert - we should always find 1 answer for each header row + lappend spaninfo [list hrow $hrow startcol $spanstartcol spanlen $spanlen] + } + return $spaninfo + } + method calculate_column_widths {args} { + set column_count [tcl::dict::size $o_columndefs] + + set opts [tcl::dict::create\ + -algorithm $o_column_width_algorithm\ + ] + foreach {k v} $args { + switch -- $k { + -algorithm { + tcl::dict::set opts $k $v + } + default { + error "Unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + set opt_algorithm [tcl::dict::get $opts -algorithm] + #puts stderr "--- recalculating column widths -algorithm $opt_algorithm" + set known_algorithms [list basic simplistic span span2] + switch -- $opt_algorithm { + basic { + #basic column by column - This allocates extra space to first span/column as they're encountered. + #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans + #The header values can extend over some of the spanned columns - but not optimally so. + set o_calculated_column_widths [list] + for {set c 0} {$c < $column_count} {incr c} { + lappend o_calculated_column_widths [my basic_column_width $c] + } + } + simplistic { + #just uses the widest column data or header element. + #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column + #This is a conservative option potentially useful in testing/debugging. + set o_calculated_column_widths [list] + for {set c 0} {$c < $column_count} {incr c} { + lappend o_calculated_column_widths [my column_width_configured $c] + } + } + span { + #widest of smallest spans first method + #set calcresult [my columncalc_spans least] + set calcresult [my columncalc_spans least_unmaxed] + set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] + } + span2 { + #allocates more evenly - but truncates headers sometimes + set calcresult [my columncalc_spans all] + set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] + } + default { + error "calculate_column_widths unknown algorithm $opt_algorithm. Known algorithms: $known_algorithms" + } + } + #remember the last algorithm used + set o_column_width_algorithm $opt_algorithm + return $o_calculated_column_widths + } + method print2 {args} { + variable full_column_cache + set full_column_cache [tcl::dict::create] + + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0} + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set blocks [list] + set colposn 0 + set numposns [llength $cols] + set padwidth 0 + set table "" + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + #lappend blocks [my get_column_by_index $c {*}$flags] + #todo - only check and store in cache if table has header or footer colspans > 1 + if {[tcl::dict::exists $full_column_cache $c]} { + #puts "!!print used full_column_cache for $c" + set columninfo [tcl::dict::get $full_column_cache $c] + } else { + set columninfo [my get_column_by_index $c -return dict {*}$flags] + tcl::dict::set full_column_cache $c $columninfo + } + set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] + set bodywidth [tcl::dict::get $columninfo bodywidth] + + if {$table eq ""} { + set table $nextcol + set height [textblock::height $table] ;#only need to get height once at start + } else { + set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] + set table [overtype::renderspace -expand_right 1 -transparent $TSUB $table[unset table] $nextcol] + #JMN + + #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] + #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] + } + incr padwidth $bodywidth + incr colposn + } + + if {[llength $cols]} { + #return [textblock::join -- {*}$blocks] + if {[tcl::dict::get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [tcl::string::repeat $TSUB $offset] + if {[tcl::dict::get $o_opts_table -title] ne ""} { + set titlealign [tcl::dict::get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[tcl::dict::get $o_opts_table -title] + } + right { + set tstring [tcl::dict::get $o_opts_table -title]$titlepad + } + default { + set tstring [tcl::dict::get $o_opts_table -title] + } + } + set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } + return $table + } else { + return "No columns matched" + } + } + + # using -startcolumn to do slightly less work + method print3 {args} { + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0} + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set blocks [list] + set numposns [llength $cols] + set colposn 0 + set padwidth 0 + set table "" + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + set columninfo [my get_column_by_index $c -return dict {*}$flags] + set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] + set bodywidth [tcl::dict::get $columninfo bodywidth] + + if {$table eq ""} { + set table $nextcol + set height [textblock::height $table] ;#only need to get height once at start + } else { + set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] + } + incr padwidth $bodywidth + incr colposn + } + + if {[llength $cols]} { + #return [textblock::join -- {*}$blocks] + if {[tcl::dict::get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [tcl::string::repeat $TSUB $offset] + if {[tcl::dict::get $o_opts_table -title] ne ""} { + set titlealign [tcl::dict::get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[tcl::dict::get $o_opts_table -title] + } + right { + set tstring [tcl::dict::get $o_opts_table -title]$titlepad + } + default { + set tstring [tcl::dict::get $o_opts_table -title] + } + } + set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } + return $table + } else { + return "No columns matched" + } + } + + #print headers and body using different join mechanisms + # using -startcolumn to do slightly less work + method print {args} { + if {![llength $args]} { + set cols [tcl::dict::keys $o_columndata] + } else { + set cols [list] + foreach colspec $args { + set allcols [tcl::dict::keys $o_columndata] + if {[tcl::string::first .. $colspec] >=0} { + set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] + if {[llength $parts] != 3} { + error "[namespace::current]::table error invalid print specification '$colspec'" + } + lassign $parts from _dd to + if {$from eq ""} {set from 0} + if {$to eq ""} {set to end} + + set indices [lrange $allcols $from $to] + lappend cols {*}$indices + } else { + set c [lindex $allcols $colspec] + if {$c ne ""} { + lappend cols $c + } + } + } + } + set numposns [llength $cols] + set colposn 0 + set padwidth 0 + set header_build "" + set body_blocks [list] + set headerheight 0 + foreach c $cols { + set flags [list] + if {$colposn == 0 && $colposn == $numposns-1} { + set flags [list -position solo] + } elseif {$colposn == 0} { + set flags [list -position left] + } elseif {$colposn == $numposns-1} { + set flags [list -position right] + } else { + set flags [list -position inner] + } + set columninfo [my get_column_by_index $c -return dict {*}$flags] + #set nextcol [tcl::dict::get $columninfo column] + set bodywidth [tcl::dict::get $columninfo bodywidth] + set headerheight [tcl::dict::get $columninfo headerheight] + #set nextcol_lines [split $nextcol \n] + #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] + #set nextcol_body [join [lrange $nextcol_lines $headerheight end] \n] + set nextcol_header [tcl::dict::get $columninfo header] + set nextcol_body [tcl::dict::get $columninfo body] + + if {$header_build eq "" && ![llength $body_blocks]} { + set header_build $nextcol_header + lappend body_blocks $nextcol_body + } else { + if {$headerheight > 0} { + set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] + } + lappend body_blocks $nextcol_body + #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] + } + incr padwidth $bodywidth + incr colposn + } + if {![llength $body_blocks]} { + set body_build "" + } else { + #body blocks should not be ragged - so can use join_basic + set body_build [textblock::join_basic -- {*}$body_blocks] + } + if {$headerheight > 0} { + set table [tcl::string::cat $header_build \n $body_build] + } else { + set table $body_build + } + + if {[llength $cols]} { + if {[tcl::dict::get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [tcl::string::repeat $TSUB $offset] + if {[tcl::dict::get $o_opts_table -title] ne ""} { + set titlealign [tcl::dict::get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[tcl::dict::get $o_opts_table -title] + } + right { + set tstring [tcl::dict::get $o_opts_table -title]$titlepad + } + default { + set tstring [tcl::dict::get $o_opts_table -title] + } + } + set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } + return $table + } else { + return "No columns matched" + } + } + method print_bodymatrix {} { + set m [my as_matrix] + $m format 2string + } + + #*** !doctools + #[list_end] + }] + #*** !doctools + # [list_end] [comment {- end enumeration provider_classes }] + #[list_end] [comment {- end itemized list textblock::class groupings -}] + } + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# +#Note: A textblock does not necessarily have lines the same length - either in number of characters or print-width +# +tcl::namespace::eval textblock { + tcl::namespace::eval cd { + #todo - save and restore existing tcl::namespace::export in case macros::cd has default exports in future + tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export *} + tcl::namespace::import ::term::ansi::code::macros::cd::* + tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export -clear} + } + proc spantest {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers [list span3 "1-span4\n2-span4 second line" span5/5 "span-all etc blah 123 hmmmmm" span2] + $t configure_column 0 -header_colspans {3 4 5 any 2} + $t configure_column 2 -headers {"" "" "" "" c2span2_etc} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + proc spantest1 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers [list "span3-any longer than other span any" "1-span4\n2-span4 second line" "span-any short aligned?" "span5/5 longest etc blah 123" span2] + $t configure_column 0 -header_colspans {any 4 any 5 2} + $t configure_column 2 -headers {"" "" "" "" c2span2_etc} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure_column 3 -header_colspans {1 0 0 0 0} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + $t configure_column 0 -blockalign right ;#trigger KNOWN BUG overwrite of right edge by last char of spanning col (in this case fullspan from left - but also happens for any span extending to rhs) + return $t + } + + #more complex colspans + proc spantest2 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} + $t configure_column 0 -header_colspans {3 4 1 any 2} + $t configure_column 1 -header_colspans {0 0 2 0 0} + $t configure_column 2 -headers {"" "" "" "" c2span2} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure_column 3 -header_colspans {1 0 2 0 0} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + proc spantest3 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" "c0span2 etc blah" c0span1} + $t configure_column 0 -header_colspans {3 4 1 any 2 1} + $t configure_column 1 -header_colspans {0 0 4 0 0 1} + $t configure_column 1 -headers {"" "" "c1span4" "" "" "c1nospan"} + $t configure_column 2 -headers {"" "" "" "" "" c2span2} + $t configure_column 2 -header_colspans {0 0 0 0 1 2} + $t configure_column 4 -headers {"4" "444" "" "" "" "44"} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + + + + proc periodic {args} { + #For an impressive interactive terminal app (javascript) + # see: https://github.com/spirometaxas/periodic-table-cli + set opts [dict get [punk::args::get_dict { + *proc -name textblock::periodic -help "A rudimentary periodic table + This is primarily a test of textblock::class::table" + + -return -default table\ + -choices {table tableobject}\ + -help "default choice 'table' returns the displayable table output" + -compact -default 1 -type boolean -help "compact true defaults: -show_vseps 0 -show_header 0 -show_edge 0" + -frame -default 1 -type boolean + -show_vseps -default "" -type boolean + -show_header -default "" -type boolean + -show_edge -default "" -type boolean + -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" + *values -min 0 -max 0 + } $args] opts] + + set opt_return [tcl::dict::get $opts -return] + if {[tcl::dict::get $opts -forcecolour]} { + set fc forcecolour + } else { + set fc "" + } + + #examples ptable.com + set elements [list\ + 1 H "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" He\ + 2 Li Be "" "" "" "" "" "" "" "" "" "" B C N O F Ne\ + 3 Na Mg "" "" "" "" "" "" "" "" "" "" Al Si P S Cl Ar\ + 4 K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr\ + 5 Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I Xe\ + 6 Cs Ba "" Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn\ + 7 Fr Ra "" Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og\ + " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ + "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ + "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ + ] + + set type_colours [list] + + set ecat [tcl::dict::create] + + set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] + set ansi [a+ {*}$fc web-black Web-gold] + set val [list ansi $ansi cat alkaline_earth] + foreach e $cat_alkaline_earth { + tcl::dict::set ecat $e $val + } + + set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] + #set ansi [a+ {*}$fc web-black Web-lightgreen] + set ansi [a+ {*}$fc black Term-113] + set val [list ansi $ansi cat reactive_nonmetal] + foreach e $cat_reactive_nonmetal { + tcl::dict::set ecat $e $val + } + + set cat [list Li Na K Rb Cs Fr] + #set ansi [a+ {*}$fc web-black Web-Khaki] + set ansi [a+ {*}$fc black Term-lightgoldenrod2] + set val [list ansi $ansi cat alkali_metals] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] + #set ansi [a+ {*}$fc web-black Web-lightsalmon] + set ansi [a+ {*}$fc black Term-orange1] + set val [list ansi $ansi cat transition_metals] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list Al Ga In Sn Tl Pb Bi Po] + set ansi [a+ {*}$fc web-black Web-lightskyblue] + set val [list ansi $ansi cat post_transition_metals] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list B Si Ge As Sb Te At] + #set ansi [a+ {*}$fc web-black Web-turquoise] + set ansi [a+ {*}$fc black Brightcyan] + set val [list ansi $ansi cat metalloids] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list He Ne Ar Kr Xe Rn] + set ansi [a+ {*}$fc web-black Web-orchid] + set val [list ansi $ansi cat noble_gases] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] + set ansi [a+ {*}$fc web-black Web-plum] + set val [list ansi $ansi cat actinoids] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] + #set ansi [a+ {*}$fc web-black Web-tan] + set ansi [a+ {*}$fc black Term-tan] + set val [list ansi $ansi cat lanthanoids] + foreach e $cat { + tcl::dict::set ecat $e $val + } + + set ansi [a+ {*}$fc web-black Web-whitesmoke] + set val [list ansi $ansi cat other] + foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { + tcl::dict::set ecat $e $val + } + + set elements1 [list] + set RST [a+] + foreach e $elements { + if {[tcl::dict::exists $ecat $e]} { + set ansi [tcl::dict::get $ecat $e ansi] + #lappend elements1 [textblock::pad $ansi$e -width 2 -which right] + #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway + lappend elements1 $ansi$e + } else { + lappend elements1 $e + } + } + + set t [list_as_table -columns 19 -return tableobject $elements1] + #(defaults to show_hseps 0) + + #todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options + + set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] + set c 0 + foreach h $header_0 { + $t configure_column $c -headers [list $h] -minwidth 2 + incr c + } + set ccount [$t column_count] + for {set c 0} {$c < $ccount} {incr c} { + $t configure_column $c -minwidth 3 + } + if {[tcl::dict::get $opts -compact]} { + #compact defaults - but let explicit arguments override + set conf [dict create -show_vseps 0 -show_header 0 -show_edge 0] + } else { + set conf [dict create -show_vseps 1 -show_header 1 -show_edge 1] + } + dict for {k v} $conf { + if {[dict get $opts $k] ne ""} { + dict set conf $k [dict get $opts $k] + } + } + $t configure {*}[dict get $conf] + + $t configure \ + -frametype_header light\ + -ansiborder_header [a+ {*}$fc brightwhite]\ + -ansibase_header [a+ {*}$fc Black]\ + -ansibase_body [a+ {*}$fc Black]\ + -ansiborder_body [a+ {*}$fc black]\ + -frametype block + + #-ansiborder_header [a+ {*}$fc web-white]\ + + if {$opt_return eq "table"} { + if {[dict get $opts -frame]} { + #set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + #set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + set output [textblock::frame -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + } else { + set output [$t print] + } + $t destroy + return $output + } + return $t + } + + proc list_as_table {args} { + set argd [punk::args::get_dict [string map [list $::textblock::frametypes] { + -return -default table -choices {table tableobject} + -frametype -default "" -help "frame type: or dict for custom frame" + -show_edge -default "" -type boolean -help "show outer border of table" + -show_seps -default "" -type boolean + -show_vseps -default "" -type boolean -help "Show vertical table separators" + -show_hseps -default "" -type boolean -help "Show horizontal table separators + (default 0 if no existing -table supplied)" + -table -default "" -type string -help "existing table object to use" + -colheaders -default "" -type list -help "list of lists. list of column header values. Outer list must match number of columns" + -header -default "" -type list -multiple 1 -help "Headers left to right" + -show_header -default "" -help "Whether to show a header row. + Leave as empty string for unspecified/automatic, + in which case it will display only if -headers list was supplied." + -action -default "append" -choices {append replace} -help "row insertion method if existing -table is supplied + if append is chosen the new values will always start at the first column" + -columns -default "" -type integer -help "Number of table columns + Will default to 2 if not using an existing -table object" + *values -min 0 -max 1 + datalist -default {} -help "flat list of table cell values which will be wrapped based on -columns value" + }] $args] + set opts [dict get $argd opts] + set datalist [dict get $argd values datalist] + + set existing_table [dict get $opts -table] + set opt_columns [dict get $opts -columns] + #set opts [tcl::dict::create\ + # -return string\ + # -frametype \uFFEF\ + # -show_edge \uFFEF\ + # -show_seps \uFFEF\ + #] + #foreach {k v} $args { + # switch -- $k { + # -return - -show_edge - -show_seps - -frametype { + # tcl::dict::set opts $k $v + # } + # default { + # error "unrecognised option '$k'. Known options [tcl::dict::keys $opts]" + # } + # } + #} + + set count [llength $datalist] + + set is_new_table 0 + if {$existing_table ne ""} { + if {[tcl::namespace::tail [info object class $existing_table]] ne "table"} { + error "textblock::list_as_table error -table must be an existing table object (e.g set t \[textblock::class::table new\])" + } + set t $existing_table + foreach prop {-frametype -show_edge -show_seps -show_vseps -show_hseps} { + if {[tcl::dict::get $opts $prop] ne ""} { + $t configure $prop [tcl::dict::get $opts $prop] + } + } + if {[dict get $opts -action] eq "replace"} { + $t row_clear + } + set cols [$t column_count] + if {[tcl::string::is integer -strict $opt_columns]} { + if {$opt_columns > $cols} { + set extra [expr {$opt_columns - $cols}] + for {set c 0} {$c < $extra} {incr c} { + $t add_column + } + } elseif {$opt_columns < $cols} { + #todo - auto add blank values in the datalist + error "Number of columns requested: $opt_columns is less than existing number of columns $cols - not yet supported" + } + set cols [$t column_count] + } + } else { + set is_new_table 1 + set colheaders {} + if {[tcl::dict::get $opts -colheaders] ne ""} { + set colheaders [dict get $opts -colheaders] + } else { + set colheaders [list] + } + set r 0 + foreach ch $colheaders { + set rows [llength $ch] + if {$r < $rows} { + set r $rows + } + } + if {[llength [tcl::dict::get $opts -header]]} { + foreach hrow [tcl::dict::get $opts -header] { + set c 0 + foreach cell $hrow { + if {[llength $colheaders] < $c+1} { + lappend colheaders [lrepeat $r {}] + } + set colinfo [lindex $colheaders $c] + if {$r > [llength $colinfo]} { + set diff [expr {$r - [llength $colinfo]}] + lappend colinfo {*}[lrepeat $diff {}] + } + lappend colinfo $cell + lset colheaders $c $colinfo + incr c + } + incr r + } + } + + + if {[llength $colheaders] > 0} { + if {[tcl::dict::get $opts -show_header] eq ""} { + set show_header 1 + } else { + set show_header [tcl::dict::get $opts -show_header] + } + } else { + if {[tcl::dict::get $opts -show_header] eq ""} { + set show_header 0 + } else { + set show_header [tcl::dict::get $opts -show_header] + } + } + + if {[tcl::string::is integer -strict $opt_columns]} { + set cols $opt_columns + if {[llength $colheaders] && $cols != [llength $colheaders]} { + error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $colheaders])" + } + } else { + #review + if {[llength $colheaders]} { + set cols [llength $colheaders] + } else { + set cols 2 ;#seems a reasonable default + } + } + #defaults for new table only + if {[tcl::dict::get $opts -frametype] eq ""} { + tcl::dict::set opts -frametype "light" + } + if {[tcl::dict::get $opts -show_edge] eq ""} { + tcl::dict::set opts -show_edge 1 + } + if {[tcl::dict::get $opts -show_seps] eq ""} { + tcl::dict::set opts -show_seps 1 + } + if {[tcl::dict::get $opts -show_vseps] eq ""} { + tcl::dict::set opts -show_vseps 1 + } + if {[tcl::dict::get $opts -show_hseps] eq ""} { + tcl::dict::set opts -show_hseps 0 + } + + set t [textblock::class::table new\ + -show_header $show_header\ + -show_edge [tcl::dict::get $opts -show_edge]\ + -frametype [tcl::dict::get $opts -frametype]\ + -show_seps [tcl::dict::get $opts -show_seps]\ + -show_vseps [tcl::dict::get $opts -show_vseps]\ + -show_hseps [tcl::dict::get $opts -show_hseps]\ + ] + if {[llength $colheaders]} { + for {set c 0} {$c < $cols} {incr c} { + $t add_column -headers [lindex $colheaders $c] + } + } else { + for {set c 0} {$c < $cols} {incr c} { + $t add_column -headers [list $c] + } + } + } + + set full_rows [expr {$count / $cols}] + set last_items [expr {$count % $cols}] + + + set rowdata [list] + set row [list] + set i 0 + if {$full_rows > 0} { + for {set r 0} {$r < $full_rows} {incr r} { + set j [expr {$i + ($cols -1)}] + set row [lrange $datalist $i $j] + incr i $cols + lappend rowdata $row + } + } + if {$last_items > 0} { + set idx [expr {$last_items -1}] + lappend rowdata [lrange $datalist end-$idx end] + } + foreach row $rowdata { + set shortfall [expr {$cols - [llength $row]}] + if {$shortfall > 0} { + set row [concat $row [lrepeat $shortfall ""]] + } + $t add_row $row + } + #puts stdout $rowdata + if {[tcl::dict::get $opts -return] eq "table"} { + set result [$t print] + if {$is_new_table} { + $t destroy + } + return $result + } else { + return $t + } + } + #return a homogenous block of characters - ie lines all same length, all same character + #printing-width in terminal columns is not necessarily same as blockwidth even if a single char is passed (could be full-width unicode character) + #This can have ansi SGR codes - but to repeat blocks containing ansi-movements, the block should first be rendered to a static output with something like overtype::left + proc block {blockwidth blockheight {char " "}} { + if {$blockwidth < 0} { + error "textblock::block blockwidth must be an integer greater than or equal to zero" + } + if {$blockheight <= 0} { + error "textblock::block blockheight must be a positive integer" + } + if {$char eq ""} {return ""} + #using tcl::string::length is ok + if {[tcl::string::length $char] == 1} { + set row [tcl::string::repeat $char $blockwidth] + set mtrx [lrepeat $blockheight $row] + return [::join $mtrx \n] + } else { + set charblock [tcl::string::map [list \r\n \n] $char] + if {[tcl::string::last \n $charblock] >= 0} { + if {$blockwidth > 1} { + #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) + set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]] + } else { + set row $charblock + } + } else { + set row [tcl::string::repeat $char $blockwidth] + } + set mtrx [lrepeat $blockheight $row] + return [::join $mtrx \n] + } + } + proc testblock {size {colour ""}} { + if {$size <1 || $size > 15} { + error "textblock::testblock only sizes between 1 and 15 inclusive supported" + } + set rainbow_list [list] + lappend rainbow_list {30 47} ;#black White + lappend rainbow_list {31 46} ;#red Cyan + lappend rainbow_list {32 45} ;#green Purple + lappend rainbow_list {33 44} ;#yellow Blue + lappend rainbow_list {34 43} ;#blue Yellow + lappend rainbow_list {35 42} ;#purple Green + lappend rainbow_list {36 41} ;#cyan Red + lappend rainbow_list {37 40} ;#white Black + lappend rainbow_list {black Yellow} + lappend rainbow_list red + lappend rainbow_list green + lappend rainbow_list yellow + lappend rainbow_list blue + lappend rainbow_list purple + lappend rainbow_list cyan + lappend rainbow_list {white Red} + + set rainbow_direction "horizontal" + set vpos [lsearch $colour vertical] + if {$vpos >= 0} { + set rainbow_direction vertical + set colour [lremove $colour $vpos] + } + set hpos [lsearch $colour horizontal] + if {$hpos >=0} { + #horizontal is the default and superfluous but allowed for symmetry + set colour [lremove $colour $hpos] + } + + + + set chars [concat [punk::lib::range 1 9] A B C D E F] + set charsubset [lrange $chars 0 $size-1] + if {"noreset" in $colour} { + set RST "" + } else { + set RST [a] + } + if {"rainbow" in $colour && $rainbow_direction eq "vertical"} { + #column first - colour change each column + set c [::join $charsubset \n] + + set clist [list] + for {set i 0} {$i <$size} {incr i} { + set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] + set ansi [a+ {*}$colour2] + + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] + lappend clist ${ansicode}$c$RST + } + if {"noreset" in $colour} { + return [textblock::join_basic -ansiresets 0 -- {*}$clist] + } else { + return [textblock::join_basic -- {*}$clist] + } + } elseif {"rainbow" in $colour} { + #direction must be horizontal + set block "" + for {set r 0} {$r < $size} {incr r} { + set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] + set ansi [a+ {*}$colour2] + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] + set row "$ansicode" + foreach c $charsubset { + append row $c + } + append row $RST + append block $row\n + } + set block [tcl::string::trimright $block \n] + return $block + } else { + #row first - + set rows [list] + foreach ch $charsubset { + lappend rows [tcl::string::repeat $ch $size] + } + set block [::join $rows \n] + if {$colour ne ""} { + set block [a+ {*}$colour]$block$RST + } + return $block + } + } + interp alias {} testblock {} textblock::testblock + + #todo - consider 'elastic tabstops' for textblocks where tab acts as a column separator and adjacent lines with the same number of tabs form a sort of table + proc width {textblock} { + #backspaces, vertical tabs ? + if {$textblock eq ""} { + return 0 + } + #textutil::tabify is a reasonable hack when there are no ansi SGR codes - but probably not always what we want even then - review + if {[tcl::string::last \t $textblock] >= 0} { + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set textblock [textutil::tabify::untabify2 $textblock $tw] + } + if {[punk::ansi::ta::detect $textblock]} { + #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) + set textblock [punk::ansi::ansistripraw $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] + } + return [punk::char::ansifreestring_width $textblock] + } + #when we know the block is uniform in width - just examine topline + proc widthtopline {textblock} { + set firstnl [tcl::string::first \n $textblock] + if {$firstnl >= 0} { + set tl [tcl::string::range $textblock 0 $firstnl] + } else { + set tl $textblock + } + if {[punk::ansi::ta::detect $tl]} { + set tl [punk::ansi::ansistripraw $tl] + } + return [punk::char::ansifreestring_width $tl] + } + #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. + proc string_length_line_max textblock { + tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] + } + proc string_length_line_min textblock { + tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}] + } + proc height {textblock} { + #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le + #empty string still has height 1 (at least for left-right/right-left languages) + + #vertical tab on a proper terminal should move directly down. + #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) + + set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list + return [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + } + #MAINTENANCE - same as overtype::blocksize? + proc size {textblock} { + if {$textblock eq ""} { + return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings + } + #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack + if {[tcl::string::last \t $textblock] >= 0} { + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set textblock [textutil::tabify::untabify2 $textblock $tw] + } + #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests + if {[punk::ansi::ta::detect $textblock]} { + set textblock [punk::ansi::ansistripraw $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] + set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] + } else { + set width [punk::char::ansifreestring_width $textblock] + } + set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list + #our concept of block-height is likely to be different to other line-counting mechanisms + set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le + + return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize ]] width height + } + proc size_as_opts {textblock} { + set sz [size $textblock] + return [dict create -width [dict get $sz width] -height [dict get $sz height]] + } + proc size_as_list {textblock} { + set sz [size $textblock] + return [list [dict get $sz width] [dict get $sz height]] + } + #must be able to handle block as string with or without newlines + #if no newlines - attempt to treat as a list + #must handle whitespace-only string,list elements, and/or lines. + #reviewing 2024 - this seems like too much magic! + proc width1 {block} { + if {$block eq ""} { + return 0 + } + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set block [textutil::tabify::untabify2 $block $tw] + if {[tcl::string::last \n $block] >= 0} { + return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [ansistrip $v]}]] + } + if {[catch {llength $block}]} { + return [::punk::char::string_width [ansistrip $block]] + } + if {[llength $block] == 0} { + #could be just a whitespace string + return [tcl::string::length $block] + } + return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [ansistrip $v]}]] + } + + #we shouldn't make textblock depend on the punk pipeline system + #pipealias ::textblock::padleft .= {list $input [tcl::string::repeat " " $indent]} |/0,padding/1> punk:lib::lines_as_list -- |> .= {lmap v $data {overtype::right $padding $v}} |> punk::lib::list_as_lines -- punk::lib::lines_as_list -- |> .= {lmap v $data {overtype::left $padding $v}} |> punk::lib::list_as_lines -- |? ?-which right|left|centre? ?-width auto|? ?-within_ansi 1|0?" + foreach {k v} $args { + switch -- $k { + -padchar - -which - -width - -overflow - -within_ansi { + tcl::dict::set opts $k $v + } + default { + error "textblock::pad unrecognised option '$k'. Usage: $usage" + } + } + } + # -- --- --- --- --- --- --- --- --- --- + set padchar [tcl::dict::get $opts -padchar] + #if padchar width (screen width) > 1 - length calculations will not be correct + #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map + #The caller may also use ansi within the padchar - although it's unlikely to be efficient. + # -- --- --- --- --- --- --- --- --- --- + set known_whiches [list l left r right c center centre] + set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] + switch -- $opt_which { + center - centre - c { + set which c + } + left - l { + set which l + } + right - r { + set which r + } + default { + error "textblock::pad unrecognised value for -which option. Known values $known_whiches" + } + } + # -- --- --- --- --- --- --- --- --- --- + set opt_width [tcl::dict::get $opts -width] + switch -- $opt_width { + "" - auto { + set width auto + } + default { + if {![tcl::string::is integer -strict $opt_width] || $opt_width < 0} { + error "textblock::pad -width must be an integer >=0" + } + set width $opt_width + } + } + # -- --- --- --- --- --- --- --- --- --- + set opt_withinansi [tcl::dict::get $opts -within_ansi] + switch -- $opt_withinansi { + 0 - 1 {} + default { + set opt_withinansi 2 + } + } + # -- --- --- --- --- --- --- --- --- --- + + set datawidth [textblock::width $block] + if {$width eq "auto"} { + set width $datawidth + } + + set lines [list] + + set padcharsize [punk::ansi::printing_length $padchar] + set pad_has_ansi [punk::ansi::ta::detect $padchar] + if {$block eq ""} { + #we need to treat as a line + set repeats [expr {int(ceil($width / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + #TODO + #review - what happens when padchar has ansi, or the width would split a double-wide unicode char? + #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) + #we should use overtype with suitable replacement char (space?) for chopped double-wides + if {!$pad_has_ansi} { + return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] + } else { + set base [tcl::string::repeat " " $width] + return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + } + + #review - tcl format can only pad with zeros or spaces? + #experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes + if 0 { + #review - surprisingly, this doesn't seem to be a performance win + #No detectable diff on small blocks - slightly worse on large blocks + if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { + #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position + #(i.e as at 2024 - lots of them) wezterm on windows at least does the right thing. + set block [tcl::string::map [list \r\n \n] $block] + if {$which eq "l"} { + set fmt "%+${padchar}*s" + } else { + set fmt "%-${padchar}*s" + } + foreach ln [split $block \n] { + #set lnwidth [punk::char::ansifreestring_width $ln] + set lnwidth [punk::char::grapheme_width_cached $ln] + set lnlen [tcl::string::length $ln] + set diff [expr $lnwidth - $lnlen] + #we need trickwidth to get format to pad a string with a different terminal width compared to string length + set trickwidth [expr {$width - $diff}] ;#may 'subtract' a positive or negative int (ie will add to trickwidth if negative) + lappend lines [format $fmt $trickwidth $ln] + } + return [::join $lines \n] + } + } + + #todo? special case trailing double-reset - insert between resets? + set lnum 0 + if {[punk::ansi::ta::detect $block]} { + set parts [punk::ansi::ta::split_codes $block] + } else { + #single plaintext part + set parts [list $block] + } + set line_chunks [list] + set line_len 0 + set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad + foreach {pt ansi} $parts { + if {$pt ne ""} { + set has_nl [expr {[tcl::string::last \n $pt]>=0}] + if {$has_nl} { + set pt [tcl::string::map [list \r\n \n] $pt] + set partlines [split $pt \n] + } else { + set partlines [list $pt] + } + set last [expr {[llength $partlines]-1}] + set p 0 + foreach pl $partlines { + lappend line_chunks $pl + #incr line_len [punk::char::ansifreestring_width $pl] + incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW + if {$p != $last} { + #do padding + set missing [expr {$width - $line_len}] + if {$missing > 0} { + #commonly in a block - many lines will have the same pad - cache based on missing + + #padchar may be more than 1 wide - because of 2wide unicode and or multiple chars + if {[tcl::dict::exists $pad_cache $missing]} { + set pad [tcl::dict::get $pad_cache $missing] + } else { + set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + if {!$pad_has_ansi} { + set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] + } else { + set base [tcl::string::repeat " " $missing] + set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + dict set pad_cache $missing $pad + } + switch -- $which-$opt_withinansi { + r-0 { + lappend line_chunks $pad + } + r-1 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { + lappend line_chunks $pad + } + } + r-2 { + lappend line_chunks $pad + } + l-0 { + set line_chunks [linsert $line_chunks 0 $pad] + } + l-1 { + if {[lindex $line_chunks 0] eq ""} { + set line_chunks [linsert $line_chunks 2 $pad] + } else { + set line_chunks [linsert $line_chunks 0 $pad] + } + } + l-2 { + if {$lnum == 0} { + if {[lindex $line_chunks 0] eq ""} { + set line_chunks [linsert $line_chunks 2 $pad] + } else { + set line_chunks [linsert $line_chunks 0 $pad] + } + } else { + set line_chunks [linsert $line_chunks 0 $pad] + } + } + } + } + lappend lines [::join $line_chunks ""] + set line_chunks [list] + set line_len 0 + incr lnum + } + incr p + } + } else { + #we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes + lappend line_chunks "" + } + #don't let trailing empty ansi affect the line_chunks length + if {$ansi ne ""} { + lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? + } + } + #pad last line + set missing [expr {$width - $line_len}] + if {$missing > 0} { + if {[tcl::dict::exists $pad_cache $missing]} { + set pad [tcl::dict::get $pad_cache $missing] + } else { + set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + if {!$pad_has_ansi} { + set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] + } else { + set base [tcl::string::repeat " " $missing] + set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + } + #set pad [tcl::string::repeat $padchar $missing] + switch -- $which-$opt_withinansi { + r-0 { + lappend line_chunks $pad + } + r-1 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { + lappend line_chunks $pad + } + } + r-2 { + if {[lindex $line_chunks end] eq ""} { + set line_chunks [linsert $line_chunks end-2 $pad] + } else { + lappend line_chunks $pad + } + #lappend line_chunks $pad + } + l-0 { + #if {[lindex $line_chunks 0] eq ""} { + # set line_chunks [linsert $line_chunks 2 $pad] + #} else { + # set line_chunks [linsert $line_chunks 0 $pad] + #} + set line_chunks [linsert $line_chunks 0 $pad] + } + l-1 { + #set line_chunks [linsert $line_chunks 0 $pad] + set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] + } + l-2 { + set line_chunks [linsert $line_chunks 0 $pad] + } + } + } + lappend lines [::join $line_chunks ""] + return [::join $lines \n] + } + + #left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single + #resulting list is no longer a valid ansisplit list + proc _insert_before_text_or_last_ansi {str ansisplits} { + if {[llength $ansisplits] == 1} { + #ansisplits was a split on plaintext only + return [list $str [lindex $ansisplits 0]] + } elseif {[llength $ansisplits] == 0} { + return [list $str] + } + if {[llength $ansisplits] %2 != 1} { + error "_insert_before_text_or_last_ansi ansisplits list is not a valid resultlist from an ansi split - must be odd number of elements pt,ansi,pt,ansi...pt" + } + set out [list] + set i 0 + set i_last_code [expr {[llength $ansisplits]-3}] ;#would normally be -2 - but our i is jumping to each pt - not every element + foreach {pt code} $ansisplits { + if {$pt ne ""} { + return [lappend out $str {*}[lrange $ansisplits $i end]] + } + if {$i == $i_last_code} { + return [lappend out $str {*}[lrange $ansisplits $i end]] + } + #code being empty can only occur when we have reached last pt + #we have returned by then. + lappend out $code + incr i 2 + } + error "_insert_before_text_or_last_ansi failed on input str:[ansistring VIEW $str] ansisplits:[ansistring VIEW $ansisplits]" + } + proc pad_test {block} { + set width [textblock::width $block] + set padtowidth [expr {$width + 10}] + set left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] + set left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] + set left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] + set right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] + set right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] + set right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] + + set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] + + set t [textblock::list_as_table -columns 3 -return tableobject $testlist] + $t configure_column 0 -headers [list "ansi"] + $t configure_column 1 -headers [list "Left"] + $t configure_column 2 -headers [list "Right"] + $t configure -show_header 1 + puts stdout [$t print] + return $t + } + + proc pad_test_blocklist {blocklist args} { + set opts [tcl::dict::create\ + -description ""\ + -blockheaders ""\ + ] + foreach {k v} $args { + switch -- $k { + -description - -blockheaders { + tcl::dict::set opts $k $v + } + default { + error "pad_test_blocklist unrecognised option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + set opt_blockheaders [tcl::dict::get $opts -blockheaders] + set bheaders [tcl::dict::create] + if {$opt_blockheaders ne ""} { + set b 0 + foreach h $opt_blockheaders { + if {$b < [llength $blocklist]} { + tcl::dict::set bheaders $b $h + } + incr b + } + } + + set b 0 + set blockinfo [tcl::dict::create] + foreach block $blocklist { + set width [textblock::width $block] + tcl::dict::set blockinfo $b width $width + set padtowidth [expr {$width + 3}] + tcl::dict::set blockinfo $b left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] + tcl::dict::set blockinfo $b left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] + tcl::dict::set blockinfo $b left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] + tcl::dict::set blockinfo $b right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] + tcl::dict::set blockinfo $b right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] + tcl::dict::set blockinfo $b right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] + incr b + } + + set r0 [list "0"] + set r1 [list "1"] + set r2 [list "2"] + set r3 [list "column\ncolours"] + + #1 + #test without table padding + #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering + #(basically a mechanism to add extra resets at start and end of each line) + #dict for {b bdict} $blockinfo { + # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] + # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] + # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] + #} + + #2 - the more useful one? + tcl::dict::for {b bdict} $blockinfo { + lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] + lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] + lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] + lappend r3 "" "" + } + + set rows [concat $r0 $r1 $r2 $r3] + + set column_ansi [a+ web-white Web-Gray] + + set t [textblock::list_as_table -columns [expr {1 + (2 * [tcl::dict::size $blockinfo])}] -return tableobject $rows] + $t configure_column 0 -headers [list [tcl::dict::get $opts -description] "within_ansi"] -ansibase $column_ansi + set col 1 + tcl::dict::for {b bdict} $blockinfo { + if {[tcl::dict::exists $bheaders $b]} { + set hdr [tcl::dict::get $bheaders $b] + } else { + set hdr "Block $b" + } + $t configure_column $col -headers [list $hdr "Left"] -minwidth [expr {$padtowidth + 2}] + $t configure_column $col -header_colspans 2 -ansibase $column_ansi + incr col + $t configure_column $col -headers [list "-" "Right"] -minwidth [expr {$padtowidth + 2}] -ansibase $column_ansi + incr col + } + $t configure -show_header 1 + puts stdout [$t print] + return $t + } + proc pad_example {} { + set headers [list] + set blocks [list] + + lappend blocks "[textblock::testblock 4 rainbow]" + lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing" + + lappend blocks "[textblock::testblock 4 rainbow][a]" + lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset" + + lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]" + lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg" + + lappend blocks "[textblock::testblock 4 {rainbow noreset}]" + lappend headers "rainbow 4x4\nno line resets\nnothing trailing" + + lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]" + lappend headers "rainbow 4x4\nno line resets\ntrailing reset" + + lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]" + lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg" + + set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] + } + proc pad_example2 {} { + set headers [list] + set blocks [list] + lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n" + lappend headers "red on blue 4x4\nno inner resets\ntrailing nl" + + lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]" + lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset" + + lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]" + lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg" + + set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] + } + + + #playing with syntax + + # pipealias ::textblock::join_width .= {list $lhs [tcl::string::repeat " " $w1] $rhs [tcl::string::repeat " " $w2]} {| + # /2,col1/1,col2/3 + # >} punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| + # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| + # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| + # >} punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] + set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] + set testblock [textblock::testblock 15 rainbow] + set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] + set framed [textblock::frame -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] + } + + + proc example {args} { + set opts [tcl::dict::create -forcecolour 0] + foreach {k v} $args { + switch -- $k { + -forcecolour { + tcl::dict::set opts $k $v + } + default { + error "textblock::example unrecognised option '$k'. Known-options: [tcl::dict::keys $opts]" + } + } + } + set opt_forcecolour 0 + if {[tcl::dict::get $opts -forcecolour]} { + set fc forcecolour + set opt_forcecolour 1 + } else { + set fc "" + } + set pleft [>punk . rhs] + set pright [>punk . lhs] + set prightair [>punk . lhs_air] + set red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold] + set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold] + set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold] + set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc blue bold] + set RST [a] + set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] + set punks [textblock::join -- $pleft $pright] + set pleft_greenb $greenb$pleft$RST + set pright_redb $redb$pright$RST + set prightair_cyanb $cyanb$prightair$RST + set cpunks [textblock::join -- $pleft_greenb $pright_redb] + set out "" + append out $punks \n + append out $cpunks \n + append out [textblock::join -- $punks $cpunks] \n + set 2frames_a [textblock::join -- [textblock::frame $cpunks] [textblock::frame $punks]] + append out $2frames_a \n + set 2frames_b [textblock::join -- [textblock::frame -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -ansiborder $greenb -title "fancypunks" $cpunks]] + append out [textblock::frame -title "punks" $2frames_b\n$RST$2frames_a] \n + set fancy [overtype::right [overtype::left [textblock::frame -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nL\nI\nF\nE"] + set spantable [[spantest] print] + append out [textblock::join -- $fancy " " $spantable] \n + #append out [textblock::frame -title gr $gr0] + append out [textblock::periodic -forcecolour $opt_forcecolour] + return $out + } + + proc example3 {{text "test\netc\nmore text"}} { + package require patternpunk + .= textblock::join -- [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7]] [>punk . lhs] |> .=>1 textblock::join -- " " |> .=>1 textblock::join -- $text |> .=>1 textblock::join -- [>punk . rhs] |> .=>1 textblock::join -- [punk::lib::list_as_lines -- [lrepeat 7 " | "]] + } + proc example2 {{text "test\netc\nmore text"}} { + package require patternpunk + .= textblock::join\ + --\ + [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7 8]]\ + [>punk . lhs]\ + " "\ + $text\ + [>punk . rhs]\ + [punk::lib::list_as_lines -- [lrepeat 8 " | "]] + } + proc table {args} { + #todo - use punk::args + upvar ::textblock::class::opts_table_defaults toptdefaults + set defaults [tcl::dict::create\ + -rows [list]\ + -headers [list]\ + -return string\ + ] + + + set defaults [tcl::dict::merge $defaults $toptdefaults] ;# -title -frametype -show_header etc + set opts [tcl::dict::merge $defaults $args] + # -- --- --- --- + set opt_return [tcl::dict::get $opts -return] + set opt_rows [tcl::dict::get $opts -rows] + set opt_headers [tcl::dict::get $opts -headers] + # -- --- --- --- + set topts [tcl::dict::create] + set toptkeys [tcl::dict::keys $toptdefaults] + tcl::dict::for {k v} $opts { + if {$k in $toptkeys} { + tcl::dict::set topts $k $v + } + } + set t [textblock::class::table new {*}$topts] + + foreach h $opt_headers { + $t add_column -headers [list $h] + } + if {[$t column_count] == 0} { + if {[llength $opt_rows]} { + set r0 [lindex $opt_rows 0] + foreach c $r0 { + $t add_column + } + } + } + foreach r $opt_rows { + $t add_row $r + } + + + + if {$opt_return eq "string"} { + set result [$t print] + $t destroy + return $result + } else { + return $t + } + } + + variable frametypes + set frametypes [list light heavy arc double block block1 block2 block2hack ascii altg] + #class::table needs to be able to determine valid frametypes + proc frametypes {} { + variable frametypes + return $frametypes + } + proc frametype {f} { + #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] + switch -- $f { + light - heavy - arc - double - block - block1 - block2 - block2hack - ascii - altg { + return [tcl::dict::create category predefined type $f] + } + default { + set is_custom_dict_ok 1 + if {[llength $f] %2 == 0} { + #custom dict may leave out keys - but cannot have unknown keys + foreach {k v} $f { + switch -- $k { + hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + default { + #k not in custom_keys + set is_custom_dict_ok 0 + break + } + } + } + } else { + set is_custom_dict_ok 0 + } + if {!$is_custom_dict_ok} { + error "frame option -type must be one of known types: $::textblock::frametypes or a dictionary with any of keys hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" + } + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + set custom_frame [tcl::dict::merge $default_custom $f] + return [tcl::dict::create category custom type $custom_frame] + } + } + } + variable framedef_cache [tcl::dict::create] + 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. + #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. + #the arc set can't even join to itself e.g with curved equivalents of T-like shapes + + #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. + variable framedef_cache + set cache_key $args + if {[tcl::dict::exists $framedef_cache $cache_key]} { + return [tcl::dict::get $framedef_cache $cache_key] + } + + set argopts [lrange $args 0 end-1] + set f [lindex $args end] + + #here we avoid the punk::args usage on the happy path, even though punk::args is fairly fast, in favour of an even faster literal switch on the happy path + #this means we have some duplication in where our flags/opts are defined: here in opts, and in spec below to give nicer error output without affecting performance. + #It also means we can't specify checks on the option types etc + set opts [tcl::dict::create\ + -joins ""\ + -boxonly 0\ + ] + set bad_option 0 + foreach {k v} $argopts { + switch -- $k { + -joins - -boxonly { + tcl::dict::set opts $k $v + } + default { + set bad_option + break + } + } + } + if {[llength $args] % 2 == 0 || $bad_option} { + #no framedef supplied, or unrecognised opt seen + set spec [string map [list $::textblock::frametypes] { + *proc -name textblock::framedef + -joins -default "" -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 -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 -help "name from the predefined frametypes + or an adhoc dictionary." + }] + #append spec \n "frametype -help \"A predefined \"" + punk::args::get_dict $spec $args + return + } + + set joins [tcl::dict::get $opts -joins] + set boxonly [tcl::dict::get $opts -boxonly] + + + #sorted order down left right up + #1 x choose 4 + #4 x choose 3 + #6 x choose 2 + #4 x choose 1 + #15 combos + + set join_directions [list] + #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode + #e.g down-light, up-heavy + set join_targets [tcl::dict::create left "" down "" right "" up ""] + foreach jt $joins { + lassign [split $jt -] direction target + if {$target ne ""} { + tcl::dict::set join_targets $direction $target + } + lappend join_directions $direction + } + set join_directions [lsort -unique $join_directions] + set do_joins [::join $join_directions _] + + + switch -- $f { + "altg" { + #old style ansi escape sequences with alternate graphics page G0 + set hl [cd::hl] + set hlt $hl + set hlb $hl + set vl [cd::vl] + set vll $vl + set vlr $vl + set tlc [cd::tlc] + set trc [cd::trc] + set blc [cd::blc] + set brc [cd::brc] + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + #No join targets available to join altg to other box styles + switch -- $do_joins { + down { + #1 + set blc [punk::ansi::g0 t] ;#(ltj) + set brc [punk::ansi::g0 u] ;#(rtj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } left { + #2 + set tlc [punk::ansi::g0 w] ;#(ttj) + set blc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + } + right { + #3 + set trc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 v] ;#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + up { + #4 + set tlc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + } + down_left { + #5 + set blc [punk::ansi::g0 n] ;#(fwj) + set tlc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 u] ;#(rtj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + set vllj [punk::ansi::g0 u] ;#(rtj) + } + down_right { + #6 + set blc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 n] ;#(fwj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + down_up { + #7 + set blc [punk::ansi::g0 t] ;#(ltj) + set brc [punk::ansi::g0 u] ;#(rtj) + + set tlc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 u] ;#(rtj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + set hltj [punk::ansi::g0 v];#(btj) + } + left_right { + #8 + #from 2 + set tlc [punk::ansi::g0 w] ;#(ttj) + set blc [punk::ansi::g0 v] ;#(btj) + #from3 + set trc [punk::ansi::g0 w] ;#(ttj) + set brc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + left_up { + #9 + set tlc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 u] ;#(rtj) + set blc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + } + right_up { + #10 + set tlc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 v] ;#(btj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + down_left_right { + #11 + set blc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 w] ;#(ttj) + set tlc [punk::ansi::g0 w] ;#(ttj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + down_left_up { + #12 + set tlc [punk::ansi::g0 n] ;#(fwj) + set blc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 u] ;#(rtj) + set brc [punk::ansi::g0 u] ;#(rtj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + down_right_up { + #13 + set tlc [punk::ansi::g0 t] ;#(ltj) + set blc [punk::ansi::g0 t] ;#(ltj) + set trc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 n] ;#(fwj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + left_right_up { + #14 + set tlc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 n] ;#(fwj) + set blc [punk::ansi::g0 v] ;#(btj) + set brc [punk::ansi::g0 v] ;#(btj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + } + down_left_right_up { + #15 + set tlc [punk::ansi::g0 n] ;#(fwj) + set blc [punk::ansi::g0 n] ;#(fwj) + set trc [punk::ansi::g0 n] ;#(fwj) + set brc [punk::ansi::g0 n] ;#(fwj) + set vllj [punk::ansi::g0 u] ;#(rtj) + set hltj [punk::ansi::g0 v];#(btj) + set vlrj [punk::ansi::g0 t] ;#(ltj) + set hlbj [punk::ansi::g0 w] ;#(ttj) + } + } + + + } + "ascii" { + set hl - + set hlt - + set hlb - + set vl | + set vll | + set vlr | + set tlc + + set trc + + set blc + + set brc + + #horizontal and vertical bar joins + #set hltj $hlt + #set hlbj $hlb + #set vllj $vll + #set vlrj $vlr + #ascii + is small - can reasonably be considered a join to anything? + set hltj + + set hlbj + + set vllj + + set vlrj + + #our corners are all + already - so we won't do anything for directions or targets + + } + "light" { + #unicode box drawing set + set hl [punk::char::charshort boxd_lhz] ;# light horizontal + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_lv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ldr] + set trc [punk::char::charshort boxd_ldl] + set blc [punk::char::charshort boxd_lur] + set brc [punk::char::charshort boxd_lul] + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + #15 combos + #sort order: down left right up + #ltj,rtj,ttj,btj e.g left T junction etc. + #Look at from the perspective of a frame/table outline with a clean border and arms pointing inwards + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'light' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - light { + set target$dir light + } + ascii - altg - arc { + set target$dir light + } + heavy { + set target$dir $target + } + default { + set target$dir other + } + } + } + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + heavy { + set blc [punk::char::charshort boxd_dhrul] ;#\u251f down hieavy and right up light (ltj) + set brc \u2527 ;#boxd_dhlul down heavy and left up light (rtj) + set hlbj \u2530 ;# down heavy (ttj) + } + light { + set blc \u251c ;#[punk::char::charshort boxd_lvr] light vertical and right (ltj) + set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + set hlbj \u252c ;# (ttj) + } + } + } + left { + #2 + switch -- $targetleft { + heavy { + set tlc \u252d ;# Left Heavy and Right Down Light (ttj) + set blc \u2535 ;# Left Heavy and Right Up Light (btj) + set vllj \u2525 ;# left heavy (rtj) + } + light { + set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + set vllj \u2524 ;# (rtj) + } + } + } + right { + #3 + switch -- $targetright { + heavy { + set trc \u252e ;#Right Heavy and Left Down Light (ttj) + set brc \u2536 ;#Right Heavy and Left up Light (btj) + set vlrj \u251d;#right heavy (ltj) + } + light { + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + set vlrj \u251c;# (ltj) + } + } + } + up { + #4 + switch -- $targetup { + heavy { + set tlc \u251e ;#up heavy (ltj) + set trc \u2526 ;#up heavy (rtj) + } + light { + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + } + } + } + down_left { + #5 + switch -- $targetdown-$targetleft { + other-light { + set blc \u2534 ;#(btj) + set tlc \u252c ;#(ttj) + #brc - default corner + set vllj \u2524 ;# (rtj) + } + other-other { + #default corners + } + other-heavy { + set blc \u2535 ;# heavy left (btj) + set tlc \u252d ;#heavy left (ttj) + #brc default corner + set vllj \u2525 ;# heavy left (rtj) + } + heavy-light { + set blc \u2541 ;# heavy down (fwj) + set tlc \u252c ;# light (ttj) + set brc \u2527 ;# heavy down (rtj) + set vllj \u2524 ;# (rtj) + set hlbj \u2530 ;# heavy down (ttj) + } + heavy-other { + set blc \u251f ;#heavy down (ltj) + #tlc - default corner + set brc \u2527 ;#heavy down (rtj) + set hlbj \u2530 ;# heavy down (ttj) + } + heavy-heavy { + set blc \u2545 ;#heavy down and left (fwj) + set tlc \u252d ;#heavy left (ttj) + set brc \u2527 ;#heavy down (rtj) + set vllj \u2525 ;# heavy left (rtj) + set hlbj \u2530 ;# heavy down (ttj) + } + light-light { + set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set tlc \u252c ;# boxd_ldhz (ttj) + set brc \u2524 ;# boxd_lvl light vertical and left(rtj) + set vllj \u2524 ;# (rtj) + set hlbj \u252c ;# (ttj) + } + light-other { + set blc \u251c ;# (ltj) + #tlc - default corner + set brc \u2524 ;# boxd_lvl (rtj) + set hlbj \u252c ;# (ttj) + } + light-heavy { + set blc \u253d ;# heavy left (fwj) + set tlc \u252d ;# heavy left (ttj) + set brc \u2524 ;# light (rtj) + set vllj \u2525 ;# heavy left (rtj) + set hlbj \u252c ;# (ttj) + } + default { + set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set tlc \u252c ;# [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc \u2524 ;# [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + } + } + } + down_right { + #6 + set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + } + down_up { + #7 + set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + } + left_right { + #8 + #from 2 + set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + #from3 + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + } + left_up { + #9 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + } + right_up { + #10 + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + } + down_left_right { + #11 + set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) + + } + down_left_up { + #12 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) + + } + down_right_up { + #13 + set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + } + left_right_up { + #14 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) + + } + down_left_right_up { + #15 + set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) + } + } + #four way junction (cd::fwj) (punk::ansi::g0 n) (punk::char::charshort lvhz) (+) + } + "heavy" { + #unicode box drawing set + set hl [punk::char::charshort boxd_hhz] ;# light horizontal + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_hv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_hdr] + set trc [punk::char::charshort boxd_hdl] + set blc [punk::char::charshort boxd_hur] + set brc [punk::char::charshort boxd_hul] + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'heavy' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - heavy { + set target$dir heavy + } + light - ascii - altg - arc { + set target$dir light + } + default { + set target$dir other + } + } + } + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + light { + set blc [punk::char::charshort boxd_dlruh] ;#\u2521 down light and right up heavy (ltj) + set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) + set hlbj \u252F ;#down light (ttj) + } + heavy { + set blc [punk::char::charshort boxd_hvr] ;# (ltj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + set hlbj \u2533 ;# down heavy (ttj) + } + } + } + left { + #2 + switch -- $targetleft { + light { + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) + set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) + set vllj \u2528 ;# left light (rtj) + } + heavy { + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set blc [punk::char::charshort boxd_huhz] ;# (btj) + set vllj \u252b ;#(rtj) + } + } + } + right { + #3 + switch -- $targetright { + light { + set trc [punk::char::charshort boxd_rlldh] ;#\u2531 Right Light and Left Down Heavy (ttj) + set brc [punk::char::charshort boxd_rlluh] ;#\u2539 Right Light and Left Up Heavy(btj) + set vlrj \u2520 ;#right light (ltj) + } + heavy { + set trc [punk::char::charshort boxd_hdhz] ;#T shape (ttj) + set brc [punk::char::charshort boxd_huhz] ;# (btj) + set vlrj \u2523 ;# (ltj) + } + } + } + up { + #4 + switch -- $targetup { + light { + set tlc [punk::char::charshort boxd_ulrdh] ;#\u2522 Up Light and Right Down Heavy (ltj) + set trc [punk::char::charshort boxd_ulldh] ;#\u252a Up Light and Left Down Heavy (rtj) + set hltj \u2537 ;# up light (btj) + } + heavy { + set tlc [punk::char::charshort boxd_hvr] ;# (ltj) + set trc [punk::char::charshort boxd_hvl] ;# (rtj) + set hltj \u253b ;# (btj) + } + } + } + down_left { + #down_left is the main join type used for 'L' shaped cell border table building where we boxlimit to {vll hlb blc} + #5 + switch -- down-$targetdown-left-$targetleft { + down-light-left-heavy { + set blc [punk::char::charshort boxd_dluhzh] ;#down light and up horizontal heavy (fwj) + set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) (at tlc down stays heavy) + set hlbj \u252F ;# down light (ttj) + set vllj \u252b ;#(rtj) + } + down-heavy-left-light { + set blc [punk::char::charshort boxd_llrvh] ;# left light and right Vertical Heavy (fwj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) (at brc left must stay heavy) + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) + set hlbj \u2533 ;# down heavy (ttj) + set vllj \u2528 ;# left light (rtj) + } + down-light-left-light { + set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) + set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) + set hlbj \u252F ;# down light (ttj) + set vllj \u2528 ;# left light (rtj) + } + down-heavy-left-heavy { + set blc [punk::char::charshort boxd_hvhz] ;# (fwj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set hlbj \u2533 ;#(ttj) + set vllj \u252b ;#(rtj) + } + down-other-left-heavy { + set blc \u253b ;#boxd_huhz Heavy Up and Horizontal (btj) + #leave brc default corner + set tlc \u2533 ;#hdhz Heavy Down and Horizontal (ttj) + + set vllj \u252b ;#(rtj) + } + down-other-left-light { + set blc \u253a ;#llruh Left Light and Right Up Heavy (btj) + #leave brc default corner + set tlc \u2532 ;#llrdh Left Light and Right Down Heavy (ttj) + + set vllj \u2528 ;# left light (rtj) + } + down-heavy-left-other { + set blc \u2523 ;#hvr Heavy Vertical and Right (ltj) + set brc \u252b ;#hvl Heavy Veritcal and Left (rtj) + #leave tlc default corner + + set hlbj \u2533 ;#(ttj) + } + down-light-left-other { + set blc \u2521 ;#dlruh Down Light and Right Up Heavy (ltj) + set brc \u2529 ;#dlluh Down Light and Left Up Heavy (rtj) + #leave tlc default corner + + set hlbj \u252F ;# down light (ttj) + } + } + } + down_right { + #6 + set blc [punk::char::charshort boxd_hvr] ;# (ltj) (blc right&up stay heavy) + set trc [punk::char::charshort boxd_hdhz] ;# (ttj) (tlc down&left stay heavy) + set brc [punk::char::charshort boxd_hvhz] ;# (fwj) (brc left&up heavy) + } + down_up { + #7 + set blc [punk::char::charshort boxd_hvr] ;# (ltj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + + set tlc [punk::char::charshort boxd_hvr] ;# (ltj) + set trc [punk::char::charshort boxd_hvl] ;# (rtj) + } + left_right { + #8 + #from 2 + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set blc [punk::char::charshort boxd_huhz] ;# (btj) + #from3 + set trc [punk::char::charshort boxd_hdhz] ;# (ttj) + set brc [punk::char::charshort boxd_huhz] ;# (btj) + } + left_up { + #9 + set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) + set trc [punk::char::charshort boxd_hvl] ;# (rtj) + set blc [punk::char::charshort boxd_huhz] ;# (btj) + } + right_up { + #10 + set tlc [punk::char::charshort boxd_hvr] ;# (ltj) + set trc [punk::char::charshort boxd_hvhz] ;# (fwj) + set brc [punk::char::charshort boxd_huhz] ;# (btj) + } + down_left_right { + #11 + set blc [punk::char::charshort boxd_hvhz] ;# (fwj) + set brc [punk::char::charshort boxd_hvhz] ;# (fwj) + set trc [punk::char::charshort boxd_hdhz] ;# (ttj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + + } + down_left_up { + #12 + set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) + set blc [punk::char::charshort boxd_hvhz] ;# (fwj) + set trc [punk::char::charshort boxd_hvl] ;# (rtj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + + } + down_right_up { + #13 + set tlc [punk::char::charshort boxd_hvr] ;# (ltj) + set blc [punk::char::charshort boxd_hvr] ;# (ltj) + set trc [punk::char::charshort boxd_hvhz] ;# (fwj) + set brc [punk::char::charshort boxd_hvhz] ;# (fwj) + } + left_right_up { + #14 + set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) + set trc [punk::char::charshort boxd_hvhz] ;# (fwj) + set blc [punk::char::charshort boxd_huhz] ;# (btj) + set brc [punk::char::charshort boxd_huhz] ;# (btj) + + } + down_left_right_up { + #15 + set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) + set blc [punk::char::charshort boxd_hvhz] ;# (fwj) + set trc [punk::char::charshort boxd_hvhz] ;# (fwj) + set brc [punk::char::charshort boxd_hvhz] ;# (fwj) + } + } + } + "double" { + #unicode box drawing set + set hl [punk::char::charshort boxd_dhz] ;# double horizontal \U2550 + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_dv] ;#double vertical \U2551 + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ddr] ;#double down and right \U2554 + set trc [punk::char::charshort boxd_ddl] ;#double down and left \U2557 + set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A + set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + # \u256c (fwj) + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'double' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - double { + set target$dir double + } + light { + set target$dir light + } + default { + set target$dir other + } + } + } + + #unicode provides no joining for double to anything else + #better to leave a gap by using default double corners if join target is not empty or double + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + double { + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + set hlbj \u2566 ;# (ttj) + } + light { + set hlbj \u2564 ;# down light (ttj) + } + } + } + left { + #2 + switch -- $targetleft { + double { + set tlc \u2566 ;# (ttj) + set blc \u2569 ;# (btj) + set vllj \u2563 ;# (rtj) + } + light { + set vllj \u2562 ;# light left (rtj) + } + } + } + right { + #3 + switch -- $targetright { + double { + set trc \u2566 ;# (ttj) + set brc \u2569 ;# (btj) + } + light { + set vlrj \u255F ;# light right (ltj) + } + } + } + up { + #4 + switch -- $targetup { + double { + set tlc \u2560 ;# (ltj) + set trc \u2563 ;# (rtj) + set hltj \u2569 ;# (btj) + } + light { + set hltj \u2567 ;#up light (btj) + } + } + } + down_left { + #5 + switch -- $targetdown-$targetleft { + double-double { + set blc \u256c ;# (fwj) + set brc \u2563 ;# (rtj) + set tlc \u2566 ;# (ttj) + set hlbj \u2566 ;# (ttj) + } + double-light { + #no corner joins treat corners like 'other' + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + + set hlbj \u2566 ;# (ttj) + set vllj \u2562 ;# light left (rtj) + + } + double-other { + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + #leave tlc as ordinary double corner + } + light-double { + + set vllj \u2563 ;# (rtj) + set hlbj \u2564 ;# light down (ttj) + + } + light-light { + + set vllj \u2562 ;# light left (rtj) + set hlbj \u2564 ;# light down (ttj) + } + other-light { + set vllj \u2562 ;# light left (rtj) + } + other-double { + set blc \u2569 ;# (btj) + #leave brc as ordinary double corner + set tlc \u2566 ;# (ttj) + } + } + } + down_right { + #6 + switch -- $targetdown-$targetright { + double-double { + set blc \u2560 ;# (ltj) + set trc \u2566 ;# (ttj) + set brc \u256c ;# (fwj) + set hlbj \u2566 ;# (ttj) + } + double-other { + set blc \u2560 ;# (ltj) + #leave trc default + set brc \u2563 ;# (rtj) + } + other-double { + #leave blc default + set trc \u2566 ;# (ttj) + set brc \u2569 ;#(btj) + } + } + } + down_up { + #7 + switch -- $targetdown-$targetup { + double-double { + set blc \u2560 ;# (ltj) + set brc \u2563 ;# (rtj) + set tlc \u2560 ;# (ltj) + set trc \u2563 ;# (rtj) + set hltj \u2569 ;# (btj) + set hlbj \u2566 ;# (ttj) + } + } + } + left_right { + #8 + + #from 2 + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set blc [punk::char::charshort boxd_huhz] ;# (btj) + #from3 + set trc [punk::char::charshort boxd_hdhz] ;# (ttj) + set brc [punk::char::charshort boxd_huhz] ;# (btj) + } + left_up { + #9 + set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) + set trc [punk::char::charshort boxd_hvl] ;# (rtj) + set blc [punk::char::charshort boxd_huhz] ;# (btj) + set hltj \u2569 ;# (btj) + set vllj \u2563 ;# (rtj) + } + right_up { + #10 + set tlc [punk::char::charshort boxd_hvr] ;# (ltj) + set trc [punk::char::charshort boxd_hvhz] ;# (fwj) + set brc [punk::char::charshort boxd_huhz] ;# (btj) + set hltj \u2569 ;# (btj) + set vlrj \u2560 ;# (ltj) + } + down_left_right { + #11 + set blc [punk::char::charshort boxd_hvhz] ;# (fwj) + set brc [punk::char::charshort boxd_hvhz] ;# (fwj) + set trc [punk::char::charshort boxd_hdhz] ;# (ttj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set hlbj \u2566 ;# (ttj) + set vlrj \u2560 ;# (ltj) + + } + down_left_up { + #12 + set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) + set blc [punk::char::charshort boxd_hvhz] ;# (fwj) + set trc [punk::char::charshort boxd_hvl] ;# (rtj) + set brc [punk::char::charshort boxd_hvl] ;# (rtj) + set hltj \u2569 ;# (btj) + set hlbj \u2566 ;# (ttj) + + } + down_right_up { + #13 + set tlc [punk::char::charshort boxd_hvr] ;# (ltj) + set blc [punk::char::charshort boxd_hvr] ;# (ltj) + set trc [punk::char::charshort boxd_hvhz] ;# (fwj) + set brc [punk::char::charshort boxd_hvhz] ;# (fwj) + set hltj \u2569 ;# (btj) + set hlbj \u2566 ;# (ttj) + } + left_right_up { + #14 + set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) + set trc [punk::char::charshort boxd_hvhz] ;# (fwj) + set blc [punk::char::charshort boxd_huhz] ;# (btj) + set brc [punk::char::charshort boxd_huhz] ;# (btj) + set hltj \u2569 ;# (btj) + + } + down_left_right_up { + #15 + set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) + set blc [punk::char::charshort boxd_hvhz] ;# (fwj) + set trc [punk::char::charshort boxd_hvhz] ;# (fwj) + set brc [punk::char::charshort boxd_hvhz] ;# (fwj) + set hltj \u2569 ;# (btj) + set hlbj \u2566 ;# (ttj) + } + } + + } + "arc" { + #unicode box drawing set + + + set hl [punk::char::charshort boxd_lhz] ;# light horizontal + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_lv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ladr] ;#light arc down and right \U256D + set trc [punk::char::charshort boxd_ladl] ;#light arc down and left \U256E + set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 + set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + #set targetdown,targetleft,targetright,targetup vars + #default empty targets to current box type 'arc' + foreach dir {down left right up} { + set target [tcl::dict::get $join_targets $dir] + switch -- $target { + "" - arc { + set target$dir self + } + default { + set target$dir other + } + } + } + + switch -- $do_joins { + down { + #1 + switch -- $targetdown { + self { + set blc \u251c ;# *light (ltj) + #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left + #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable + #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal + + #set brc \u2524 ;# *light(rtj) + #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) + } + } + } + left { + #2 + switch -- $targetleft { + self { + set tlc \u252c ;# *light(ttj) - need a low positioned curved y shape - nothing apparent + #set blc \u2144 ;# (btj) - upside down y - positioning too low for arc + set blc \u2534 ;# *light (btj) + } + } + } + right { + #3 + switch -- $targetright { + self { + set trc \u252c ;# *light (ttj) + #set brc \u2144 ;# (btj) + set brc \u2534 ;# *light (btj) + } + } + } + up { + #4 + switch -- $targetup { + self { + set tlc \u251c ;# *light (ltj) + set trc \u2524 ;# *light(rtj) + } + } + } + down_left { + #5 + switch -- $targetdown-$targetleft { + self-self { + #set blc \u27e1 ;# white concave-sided diamond - positioned too far right + #set blc \u27e3 ;# concave sided diamond with rightwards tick - positioned too low, too right - big gaps + set brc \u2524 ;# *light (rtj) + set tlc \u252c ;# *light (ttj) + } + self-other { + #set blc \u2560 ;# (ltj) + #set brc \u2563 ;# (rtj) + #leave tlc as ordinary double corner + } + other-self { + #set blc \u2569 ;# (btj) + #leave brc as ordinary double corner + #set tlc \u2566 ;# (ttj) + } + } + } + } + } + block1 { + #box drawing as far as we can go without extra blocks from legacy computing unicode block - which is unfortunately not commonly supported + set hlt \u2581 ;# lower one eighth block + set hlb \u2594 ;# upper one eighth block + set vll \u258f ;# left one eighth block + set vlr \u2595 ;# right one eighth block + set tlc \u2581 ;# lower one eighth block + set trc \u2581 ;# lower one eighth block + set blc \u2594 ;# upper one eighth block + set brc \u2594 ;# upper one eight block + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + } + block2 { + #the resultant table will have text appear towards top of each box + #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps + set hlt \u2594 ;# upper one eighth block + set hlb \u2581 ;# lower one eighth block + set vlr \u2595 ;# right one eighth block + set vll \u258f ;# left one eighth block + + #some terminals (on windows as at 2024) miscount width of these single-width blocks internally + #resulting in extra spacing that is sometimes well removed from the character itself (e.g at next ansi reset) + #This was fixed in windows-terminal based systems (2021) but persists in others. + #https://github.com/microsoft/terminal/issues/11694 + set tlc \U1fb7d ;#legacy block + set trc \U1fb7e ;#legacy block + set blc \U1fb7c ;#legacy block + set brc \U1fb7f ;#legacy block + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + + } + block2hack { + #the resultant table will have text appear towards top of each box + #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps + set hlt \u2594 ;# upper one eighth block + set hlb \u2581 ;# lower one eighth block + set vlr \u2595 ;# right one eighth block + set vll \u258f ;# left one eighth block + + #see comments in block2 regarding the problems in some terminals that this *may* hack around to some extent. + #the caller probably only needs block2hack if block2 doesn't work + + #1) + #review - this hack looks sort of promising - but overtype::renderline needs fixing ? + #set tlc \U1fb7d\b ;#legacy block + #set trc \U1fb7e\b ;#legacy block + #set blc \U1fb7c\b ;#legacy block + #set brc \U1fb7f\b ;#legacy block + + #2) - works on cmd.exe and some others + # a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones + #known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway) + #this hack has a reasonable chance of working + #except that the punk overtype library does recognise PMs + #A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through! + #ugly - in that we don't know the application specifics of what the PM data contains and where it's going. + set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block + set trc \U1fb7e\x1b^\b\x1b\\ ;#legacy block + set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block + set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy block + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + } + block { + set hlt \u2580 ;#upper half + set hlb \u2584 ;#lower half + set vll \u258c ;#left half + set vlr \u2590 ;#right half + + set tlc \u259b ;#upper left corner half + set trc \u259c + set blc \u2599 + set brc \u259f + + #horizontal and vertical bar joins + set hltj $hlt + set hlbj $hlb + set vllj $vll + set vlrj $vlr + } + default { + 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 + 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" + } + #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 { + hl - vl - tlc - trc - blc - brc - hlt - hlb - vll - vlr - hltj - hlbj - vllj - vlrj {} + default { + error "textblock::frametype '$f' has unknown element '$k'" + } + } + } + #verified keys - safe to extract as vars + set custom_frame [tcl::dict::merge $default_custom $f] + tcl::dict::with custom_frame {} ;#extract keys as vars + #longer j vars must be after their more specific counterparts in the list being processed by foreach + foreach t {hlt hlb vll vlr hltj hlbj vllj vlrj} { + if {[tcl::dict::exists $custom_frame $t]} { + set $t [tcl::dict::get $custom_frame $t] + } else { + #set more explicit type to it's more general counterpart if it's missing + #e.g hlt -> hl + #e.g hltj -> hlt + set $t [set [string range $t 0 end-1]] + } + } + #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set + #horizontal and vertical bar joins - key/variable ends with 'j' + } + } + if {$boxonly} { + set result [tcl::dict::create\ + tlc $tlc hlt $hlt trc $trc\ + vll $vll vlr $vlr\ + blc $blc hlb $hlb brc $brc\ + ] + tcl::dict::set framedef_cache $cache_key $result + return $result + } else { + set result [tcl::dict::create\ + tlc $tlc hlt $hlt trc $trc\ + vll $vll vlr $vlr\ + blc $blc hlb $hlb brc $brc\ + hltj $hltj\ + hlbj $hlbj\ + vllj $vllj\ + vlrj $vlrj\ + ] + tcl::dict::set framedef_cache $cache_key $result + return $result + } + } + + variable frame_cache + set frame_cache [tcl::dict::create] + proc frame_cache {args} { + set argd [punk::args::get_dict { + -action -default "" -choices {clear} -help "Clear the textblock::frame_cache dictionary" + -pretty -default 1 -help "Use 'pdict textblock::frame_cache */*' for prettier output" + *values -min 0 -max 0 + } $args] + set action [dict get $argd opts -action] + + if {$action ni [list clear ""]} { + error "frame_cache action '$action' not understood. Valid actions: clear" + } + variable frame_cache + if {[dict get $argd opts -pretty]} { + set out [pdict -chan none frame_cache */*] + } else { + set out "" + if {[catch { + set termwidth [tcl::dict::get [punk::console::get_size] columns] + }]} { + set termwidth 80 + } + + tcl::dict::for {k v} $frame_cache { + lassign $v _f frame _used used + set fwidth [textblock::widthtopline $frame] + #review - are cached frames uniform width lines? + #set fwidth [textblock::width $frame] + set frameinfo "$k used:$used " + set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] + if {$allinone_width >= $termwidth} { + #split across 2 lines + append out "$frameinfo\n" + append out $frame \n + } else { + append out [textblock::join -- $frameinfo $frame]\n + } + append out \n ;# frames used to build tables often have joins - keep a line in between for clarity + } + } + if {$action eq "clear"} { + set frame_cache [tcl::dict::create] + append out \nCLEARED + } + return $out + } + + + #options before content argument - which is allowed to be absent + #frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation. + # + #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) + # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? + #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand + #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it + # - but we would need to maintain support for the rendered-string based operations too. + proc frame {args} { + variable frametypes + variable use_md5 + + #counterintuitively - in-proc dict create each time is generally slightly faster than linked namespace var + set opts [tcl::dict::create\ + -etabs 0\ + -type light\ + -boxlimits [list hl vl tlc blc trc brc]\ + -boxmap {}\ + -joins [list]\ + -title ""\ + -subtitle ""\ + -width ""\ + -height ""\ + -ansiborder ""\ + -ansibase ""\ + -blockalign "centre"\ + -textalign "left"\ + -ellipsis 1\ + -usecache 1\ + -buildcache 1\ + -pad 1\ + -crm_mode 0\ + ] + #-pad 1 is default so that simple 'textblock::frame "[a+ Red]a \nbbb[a]" extends the bg colour on the short ragged lines (and empty lines) + # for ansi art - -pad 0 is likely to be preferable + + set expect_optval 0 + set argposn 0 + set pmax [expr {[llength $args]-1}] + set has_contents 0 ;#differentiate between empty string and no content supplied + set contents "" + set arglist [list] + foreach a $args { + if {!$expect_optval} { + if {$argposn < $pmax} { + if {[tcl::string::match -* $a]} { + set expect_optval 1 + lappend arglist $a + } else { + error "textblock::frame expects -option pairs" + } + } else { + set has_contents 1 + set contents $a + } + } else { + lappend arglist $a + set expect_optval 0 + } + incr argposn + } + + #set contents [lindex $args end] + #set arglist [lrange $args 0 end-1] + if {[llength $arglist] % 2 != 0} { + error "Usage frame ?-type unicode|altg|ascii|? ?-title ? ?-subtitle ? ?-width ? ?-ansiborder ? ?-boxlimits hl|hlt|hlb|vl|vll|vlr|tlc|blc|brc? ?-joins left|right|up|down? " + } + #todo args -justify left|centre|right (center) + + #todo -blockalignbias -textalignbias? + #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache + foreach {k v} $arglist { + switch -- $k { + -etabs - -type - -boxlimits - -boxmap - -joins + - -title - -subtitle - -width - -height + - -ansiborder - -ansibase + - -blockalign - -textalign - -ellipsis + - -crm_mode + - -usecache - -buildcache - -pad { + tcl::dict::set opts $k $v + } + default { + error "frame option '$k' not understood. Valid options are [tcl::dict::keys $opts]" + } + } + } + # -- --- --- --- --- --- + set opt_etabs [tcl::dict::get $opts -etabs] + set opt_type [tcl::dict::get $opts -type] + set opt_boxlimits [tcl::dict::get $opts -boxlimits] + set opt_joins [tcl::dict::get $opts -joins] + set opt_boxmap [tcl::dict::get $opts -boxmap] + set opt_usecache [tcl::dict::get $opts -usecache] + set opt_buildcache [tcl::dict::get $opts -buildcache] + set opt_pad [tcl::dict::get $opts -pad] + set opt_crm_mode [tcl::dict::get $opts -crm_mode] + set usecache $opt_usecache ;#may need to override + set buildcache $opt_buildcache + set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] + + set known_frametypes $frametypes ;# light, heavey etc as defined in the ::textblock::frametypes variable + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + + lassign [textblock::frametype $opt_type] _cat category _type ftype + if {$category eq "custom"} { + set custom_frame $ftype + set frameset "custom" + set framedef $custom_frame + } else { + #category = predefined + set frameset $ftype ;# light,heavy etc + set framedef $ftype + } + + set is_boxlimits_ok 1 + set exact_boxlimits [list] + foreach v $opt_boxlimits { + switch -- $v { + hl { + lappend exact_boxlimits hlt hlb + } + vl { + lappend exact_boxlimits vll vlr + } + hlt - hlb - vll - vlr - tlc - trc - blc - brc { + lappend exact_boxlimits $v + } + default { + #k not in custom_keys + set is_boxlimits_ok 0 + break + } + } + } + if {!$is_boxlimits_ok} { + error "frame option -boxlimits '$opt_boxlimits' must contain only values from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" + } + set exact_boxlimits [lsort -unique $exact_boxlimits] + + set is_joins_ok 1 + foreach v $opt_joins { + lassign [split $v -] direction target + switch -- $direction { + left - right - up - down {} + default { + set is_joins_ok 0 + break + } + } + switch -- $target { + "" - light - heavy - ascii - altg - arc - double - custom - block - block1 - block2 {} + default { + set is_joins_ok 0 + break + } + } + } + if {!$is_joins_ok} { + error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light" + } + set is_boxmap_ok 1 + #safe jumptable test + #dict for {boxelement subst} $opt_boxmap {} + tcl::dict::for {boxelement subst} $opt_boxmap { + switch -- $boxelement { + hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + default { + set is_boxmap_ok 0 + break + } + } + } + if {!$is_boxmap_ok} { + error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" + } + + #sorted order down left right up + #1 x choose 4 + #4 x choose 3 + #6 x choose 2 + #4 x choose 1 + #15 combos + + set join_directions [list] + #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode + #e.g down-light, up-heavy + set join_targets [tcl::dict::create left "" down "" right "" up ""] + foreach jt $opt_joins { + lassign [split $jt -] direction target + if {$target ne ""} { + tcl::dict::set join_targets $direction $target + } + lappend join_directions $direction + } + set join_directions [lsort -unique $join_directions] + set do_joins [::join $join_directions _] + + + # -- --- --- --- --- --- + set opt_title [tcl::dict::get $opts -title] + set opt_subtitle [tcl::dict::get $opts -subtitle] + set opt_width [tcl::dict::get $opts -width] + set opt_height [tcl::dict::get $opts -height] + # -- --- --- --- --- --- + set opt_blockalign [tcl::dict::get $opts -blockalign] + switch -- $opt_blockalign { + left - right - centre - center {} + default { + error "frame option -blockalign must be left|right|centre|center - received: $opt_blockalign" + } + } + #these are all valid commands for overtype:: + # -- --- --- --- --- --- + set opt_textalign [tcl::dict::get $opts -textalign] + switch -- $opt_textalign { + left - right - centre - center {} + default { + error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" + } + } + # -- --- --- --- --- --- + + set opt_ansiborder [tcl::dict::get $opts -ansiborder] + set opt_ansibase [tcl::dict::get $opts -ansibase] ;#experimental + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + # -- --- --- --- --- --- + + if {$has_contents} { + if {[tcl::string::last \t $contents] >= 0} { + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + if {$opt_etabs} { + set contents [textutil::tabify::untabify2 $contents $tw] + } + } + set contents [tcl::string::map [list \r\n \n] $contents] + if {$opt_crm_mode} { + if {$opt_height eq ""} { + set h [textblock::height $contents] + } else { + set h [expr {$opt_height -2}] + } + if {$opt_width eq ""} { + set w [textblock::width $contents] + } else { + set w [expr {$opt_width -2}] + } + set contents [overtype::renderspace -crm_mode 1 -wrap 1 -width $w -height $h "" $contents] + } + set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged) + set actual_contentheight [textblock::height $contents] + } else { + set actual_contentwidth 0 + set actual_contentheight 0 + } + + if {$opt_title ne ""} { + set titlewidth [punk::ansi::printing_length $opt_title] + set content_or_title_width [expr {max($actual_contentwidth,$titlewidth)}] + } else { + set titlewith 0 + set content_or_title_width $actual_contentwidth + } + + if {$opt_width eq ""} { + set frame_inner_width $content_or_title_width + } else { + set frame_inner_width [expr {max(0,$opt_width - 2)}] ;#default + } + + if {$opt_height eq ""} { + set frame_inner_height $actual_contentheight + } else { + set frame_inner_height [expr {max(0,$opt_height -2)}] ;#default + } + if {$frame_inner_height == 0 && $frame_inner_width == 0} { + set has_contents 0 + } + #todo - render it with vertical overflow so we can process ansi moves? + #set linecount [textblock::height $contents] + set linecount $frame_inner_height + + # -- --- --- --- --- --- --- --- --- + variable frame_cache + #review - custom frame affects frame_inner_width - exclude from caching? + #set cache_key [concat $arglist $frame_inner_width $frame_inner_height] + set hashables [concat $arglist $frame_inner_width $frame_inner_height] + + if {$use_md5} { + #package require md5 ;#already required at package load + if {[package vsatisfies [package present md5] 2- ] } { + set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review + } else { + set hash [md5::md5 [encoding convertto utf-8 $hashables]] + } + } else { + set hash $hashables + } + + set cache_key "$hash-$frame_inner_width-$frame_inner_height-actualcontentwidth:$actual_contentwidth" + #should be in a unicode private range different to that used in table construction + #e.g BMP PUA U+E000 -> U+F8FF - although this is commonly used for example by nerdfonts + #also supplementary private use blocks + #however these display double wide on for example cmd terminal despite having wcswidth 1 (makes layout debugging difficult) + #U+F0000 -> U+FFFD + #U+100000 -> U+10FFFD + #FSUB options: \uf0ff \uF1FF \uf2ff (no nerdfont glyphs - should look like standard replacement char) \uF2DD (circular thingy) + #should be something someone is unlikely to use as part of a custom frame character. + #ideally a glyph that doesn't auto-expand into whitespace and is countable when in a string (narrower is better) + #As nerdfont glyphs tend to be mostly equal height & width - circular glyphs tend to be more distinguishable in a string + #terminal settings may need to be adjusted to stop auto glyph resizing - a rather annoying misfeature that some people seem to think they like. + #e.g in wezterm config: allow_square_glyphs_to_overflow_width = "Never" + #review - we could consider wasting a few cycles to check for a conflict and use a different FSUB + set FSUB \uF2DD + + + #this occurs commonly in table building with colspans - review + if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { + set usecache 0 + #set buildcache 0 ;#comment out for debug/analysis so we can see + #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" + set cache_key [a+ Web-red web-white]$cache_key[a] + } + if {$buildcache && ($actual_contentwidth < $frame_inner_width)} { + #colourise cache_key to warn + if {$actual_contentwidth == 0} { + #we can still substitute with right length + set cache_key [a+ Web-steelblue web-black]$cache_key[a] + } else { + #actual_contentwidth is narrower than frame - check template's patternwidth + if {[tcl::dict::exists $frame_cache $cache_key]} { + set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] + } else { + set cache_patternwidth $actual_contentwidth + } + if {$actual_contentwidth < $cache_patternwidth} { + set usecache 0 + set cache_key [a+ Web-orange web-black]$cache_key[a] + } elseif {$actual_contentwidth == $cache_patternwidth} { + #set usecache 1 + } else { + #actual_contentwidth > pattern + set usecache 0 + set cache_key [a+ Web-red web-black]$cache_key[a] + } + } + } + + #JMN debug + #set usecache 0 + + set is_cached 0 + if {$usecache && [tcl::dict::exists $frame_cache $cache_key]} { + set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] + set template [tcl::dict::get $frame_cache $cache_key frame] + set used [tcl::dict::get $frame_cache $cache_key used] + tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record + set is_cached 1 + + } + + # -- --- --- --- --- --- --- --- --- + if {!$is_cached} { + set rst [a] + #set column [tcl::string::repeat " " $frame_inner_width] ;#default - may need to override for custom frame + set underlayline [tcl::string::repeat " " $frame_inner_width] + set underlay [::join [lrepeat $linecount $underlayline] \n] + + + set vll_width 1 ;#default for all except custom (printing width) + set vlr_width 1 + + set framedef [textblock::framedef -joins $opt_joins $framedef] + tcl::dict::with framedef {} ;#extract vll,hlt,tlc etc vars + + #puts "---> $opt_boxmap" + #review - we handle double-wide in custom frames - what about for boxmaps? + tcl::dict::for {boxelement sub} $opt_boxmap { + if {$boxelement eq "vl"} { + set vll $sub + set vlr $sub + set hl $sub + } elseif {$boxelement eq "hl"} { + set hlt $sub + set hlb $sub + set hl $sub + } else { + set $boxelement $sub + } + } + + switch -- $frameset { + custom { + #REVIEW - textblock::table assumes that at least the vl elements are 1-wide + #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though + #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely + set vll_width [punk::ansi::printing_length $vll] + set hlb_width [punk::ansi::printing_length $hlb] + set hlt_width [punk::ansi::printing_length $hlt] + + set vlr_width [punk::ansi::printing_length $vlr] + + set tlc_width [punk::ansi::printing_length $tlc] + set trc_width [punk::ansi::printing_length $trc] + set blc_width [punk::ansi::printing_length $blc] + set brc_width [punk::ansi::printing_length $brc] + + + set framewidth [expr {$frame_inner_width + 2}] ;#reverse default assumption + if {$opt_width eq ""} { + #width wasn't specified - so user is expecting frame to adapt to title/contents + #content shouldn't truncate because of extra wide frame + #review - punk::console::get_size ? wrapping? quite hard to support with colspans + set frame_inner_width $content_or_title_width + set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width + set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] + } else { + set frame_inner_width [expr $opt_width - $vll_width - $vlr_width] ;#content may be truncated + set tbarwidth [expr {$opt_width - $tlc_width - $trc_width}] + set bbarwidth [expr {$opt_width - $blc_width - $brc_width}] + } + #set column [tcl::string::repeat " " $frame_inner_width] + set underlayline [tcl::string::repeat " " $frame_inner_width] + set underlay [::join [lrepeat $linecount $underlayline] \n] + #cache? + + if {$hlt_width == 1} { + set tbar [tcl::string::repeat $hlt $tbarwidth] + } else { + #possibly mixed width chars that make up hlt - tcl::string::range won't get width right + set blank [tcl::string::repeat " " $tbarwidth] + if {$hlt_width > 0} { + set count [expr {($tbarwidth / $hlt_width) + 1}] + } else { + set count 0 + } + set tbar [tcl::string::repeat $hlt $count] + #set tbar [tcl::string::range $tbar 0 $tbarwidth-1] + set tbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $tbar];#spaces for exposed halves of 2w chars instead of default replacement character + } + if {$hlb_width == 1} { + set bbar [tcl::string::repeat $hlb $bbarwidth] + } else { + set blank [tcl::string::repeat " " $bbarwidth] + if {$hlb_width > 0} { + set count [expr {($bbarwidth / $hlb_width) + 1}] + } else { + set count 0 + } + set bbar [tcl::string::repeat $hlb $count] + #set bbar [tcl::string::range $bbar 0 $bbarwidth-1] + set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar] + } + } + altg { + set tbar [tcl::string::repeat $hlt $frame_inner_width] + set tbar [cd::groptim $tbar] + set bbar [tcl::string::repeat $hlb $frame_inner_width] + set bbar [cd::groptim $bbar] + } + default { + set tbar [tcl::string::repeat $hlt $frame_inner_width] + set bbar [tcl::string::repeat $hlb $frame_inner_width] + + } + } + + set leftborder 0 + set rightborder 0 + set topborder 0 + set bottomborder 0 + # hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + #puts "----->$exact_boxlimits" + foreach lim $exact_boxlimits { + switch -- $lim { + hlt { + set topborder 1 + } + hlb { + set bottomborder 1 + } + vll { + set leftborder 1 + } + vlr { + set rightborder 1 + } + tlc { + set topborder 1 + set leftborder 1 + } + trc { + set topborder 1 + set rightborder 1 + } + blc { + set bottomborder 1 + set leftborder 1 + } + brc { + set bottomborder 1 + set rightborder 1 + } + } + } + if {$opt_width ne "" && $opt_width < 2} { + set rightborder 0 + } + #keep lhs/rhs separate? can we do vertical text on sidebars? + set lhs [tcl::string::repeat $vll\n $linecount] + set lhs [tcl::string::range $lhs 0 end-1] + set rhs [tcl::string::repeat $vlr\n $linecount] + set rhs [tcl::string::range $rhs 0 end-1] + + + if {$opt_ansiborder ne ""} { + set tbar $opt_ansiborder$tbar$rst + set bbar $opt_ansiborder$bbar$rst + set tlc $opt_ansiborder$tlc$rst + set trc $opt_ansiborder$trc$rst + set blc $opt_ansiborder$blc$rst + set brc $opt_ansiborder$brc$rst + + set lhs $opt_ansiborder$lhs$rst ;#wrap the whole block and let textblock::join figure it out + set rhs $opt_ansiborder$rhs$rst + } + + #boxlimits used for partial borders in table generation + set all_exact_boxlimits [list vll vlr hlt hlb tlc blc trc brc] + set unspecified_limits [struct::set difference $all_exact_boxlimits $exact_boxlimits] + foreach lim $unspecified_limits { + switch -- $lim { + vll { + set blank_vll [tcl::string::repeat " " $vll_width] + set lhs [tcl::string::repeat $blank_vll\n $linecount] + set lhs [tcl::string::range $lhs 0 end-1] + } + vlr { + set blank_vlr [tcl::string::repeat " " $vlr_width] + set rhs [tcl::string::repeat $blank_vlr\n $linecount] + set rhs [tcl::string::range $rhs 0 end-1] + } + hlt { + set bar_width [punk::ansi::printing_length $tbar] + set tbar [tcl::string::repeat " " $bar_width] + } + tlc { + set tlc_width [punk::ansi::printing_length $tlc] + set tlc [tcl::string::repeat " " $tlc_width] + } + trc { + set trc_width [punk::ansi::printing_length $trc] + set trc [tcl::string::repeat " " $trc_width] + } + hlb { + set bar_width [punk::ansi::printing_length $bbar] + set bbar [tcl::string::repeat " " $bar_width] + } + blc { + set blc_width [punk::ansi::printing_length $blc] + set blc [tcl::string::repeat " " $blc_width] + } + brc { + set brc_width [punk::ansi::printing_length $brc] + set brc [tcl::string::repeat " " $brc_width] + } + } + } + + if {$opt_title ne ""} { + set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off + } else { + set topbar $tbar + } + if {$opt_subtitle ne ""} { + set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off + } else { + set bottombar $bbar + } + if {$opt_ansibase eq ""} { + set rstbase [a] + } else { + set rstbase [a]$opt_ansibase + } + + if {$opt_title ne ""} { + #title overrides -boxlimits for topborder + set topborder 1 + } + set fs "" + set fscached "" + set cache_patternwidth 0 + #todo - output nothing except maybe newlines depending on if opt_height 0 and/or opt_width 0? + if {$topborder} { + if {$leftborder && $rightborder} { + append fs $tlc$topbar$trc + } else { + if {$leftborder} { + append fs $tlc$topbar + } elseif {$rightborder} { + append fs $topbar$trc + } else { + append fs $topbar + } + } + } + append fscached $fs + if {$has_contents || $opt_height > 2} { + #if {$topborder && $fs ne "xx"} { + # append fs \n + #} + if {$topborder} { + append fs \n + append fscached \n + } + switch -- $opt_textalign { + right {set pad "left"} + left {set pad "right"} + default {set pad $opt_textalign} + } + #set textaligned_contents [textblock::pad $contents -width $actual_contentwidth -which $pad -within_ansi 1] + #set inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$textaligned_contents] + + set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth] + set cache_patternwidth $actual_contentwidth + set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n] + set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern] + #after overtype::block - our actual patternwidth may be less + set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] + + if {$leftborder && $rightborder} { + #set bodyparts [list $lhs $inner $rhs] + set cache_bodyparts [list $lhs $cache_inner $rhs] + } else { + if {$leftborder} { + #set bodyparts [list $lhs $inner] + set cache_bodyparts [list $lhs $cache_inner] + } elseif {$rightborder} { + #set bodyparts [list $inner $rhs] + set cache_bodyparts [list $cache_inner $rhs] + } else { + #set bodyparts [list $inner] + set cache_bodyparts [list $cache_inner] + } + } + #set body [textblock::join -- {*}$bodyparts] + set cache_body [textblock::join -- {*}$cache_bodyparts] + append fscached $cache_body + #append fs $body + } + + if {$opt_height eq "" || $opt_height > 1} { + if {$opt_subtitle ne ""} { + #subtitle overrides boxlimits for bottomborder + set bottomborder 1 + } + if {$bottomborder} { + if {($topborder & $fs ne "xx" ) || ($has_contents || $opt_height > 2)} { + #append fs \n + append fscached \n + } + if {$leftborder && $rightborder} { + #append fs $blc$bottombar$brc + append fscached $blc$bottombar$brc + } else { + if {$leftborder} { + #append fs $blc$bottombar + append fscached $blc$bottombar + } elseif {$rightborder} { + #append fs $bottombar$brc + append fscached $bottombar$brc + } else { + #append fs $bottombar + append fscached $bottombar + } + } + } + } + set template $fscached + ;#end !$is_cached + } + + #use the same mechanism to build the final frame - whether from cache or template + if {$actual_contentwidth == 0} { + set fs [tcl::string::map [list $FSUB " "] $template] + } else { + set resultlines [list] + set overwritable [tcl::string::repeat $FSUB $cache_patternwidth] + set contentindex 0 + switch -- $opt_textalign { + left {set pad right} + right {set pad left} + default {set pad $opt_textalign} + } + + #review + if {[tcl::string::is integer -strict $opt_height] && $actual_contentheight < ($opt_height -2)} { + set diff [expr {($opt_height -2) - $actual_contentheight}] + append contents [::join [lrepeat $diff \n] ""] + } + + if {$opt_pad} { + set paddedcontents [textblock::pad $contents -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) + set paddedwidth [textblock::widthtopline $paddedcontents] + #review - horizontal truncation + if {$paddedwidth > $cache_patternwidth} { + set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents] + } + #important to supply end of opts -- to textblock::join - particularly here with arbitrary data + set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays + } else { + set cwidth [textblock::width $contents] + if {$cwidth > $cache_patternwidth} { + set contents [overtype::renderspace -width $cache_patternwidth "" $contents] + } + set contentblock [textblock::join -- $contents] + } + + set tlines [split $template \n] + + #we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too. + #after textblock::join the reset will be a separate code ie should be exactly ESC[0m + set R [a] + set rlen [tcl::string::length $R] + set clines [split $contentblock \n] + + foreach tline $tlines { + if {[tcl::string::first $FSUB $tline] >= 0} { + set content_line [lindex $clines $contentindex] + if {[tcl::string::first $R $content_line] == 0} { + set content_line [tcl::string::range $content_line $rlen end] + } + #make sure to replay opt_ansibase to the right of the replacement + lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline] + incr contentindex + } else { + lappend resultlines $tline + } + } + set fs [::join $resultlines \n] + } + + + if {$is_cached} { + return $fs + } else { + if {$buildcache} { + tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] + } + return $fs + } + } + proc gcross {args} { + set argd [punk::args::get_dict { + -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block + Only cross sizes that divide the size of the overall block will be used. + e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block. + Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) + If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. + " + *values -min 1 + size -default 1 -type integer + } $args] + set size [dict get $argd values size] + set opts [dict get $argd opts] + + if {$size == 0} { + return "" + } + + set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] + + #set fit_size [punk::lib::greatestOddFactor $size] + set fit_size $size + if {$opt_max_cross_size == 0} { + set max_cross_size $fit_size + } else { + #todo - only allow divisors + #set testsize [expr {min($fit_size,$opt_max_cross_size)}] + + set factors [punk::lib::factors $size] + #pick odd size in list that is smaller or equal to test_size + set max_cross_size [lindex $factors end] + set last_ok [lindex $factors 0] + for {set i 0} {$i < [llength $factors]} {incr i} { + set s [lindex $factors $i] + if {$s > $opt_max_cross_size} { + break + } + set last_ok $s + } + set max_cross_size $last_ok + } + set crosscount [expr {$size / $max_cross_size}] + + package require punk::char + set x [punk::char::charshort boxd_ldc] + set bs [punk::char::charshort boxd_ldgullr] + set fs [punk::char::charshort boxd_ldgurll] + + set onecross "" + set crossrows [list] + set armsize [expr {int(floor($max_cross_size /2))}] + set row [lrepeat $max_cross_size " "] + #toparm + for {set i 0} {$i < $armsize} {incr i} { + set r $row + lset r $i $bs + lset r end-$i $fs + #append onecross [::join $r ""] \n + lappend crossrows [::join $r ""] + } + + if {$max_cross_size % 2 != 0} { + #only put centre cross in for odd sized crosses + set r $row + lset r $armsize $x + #append onecross [::join $r ""] \n + lappend crossrows [::join $r ""] + } + + for {set i [expr {$armsize -1}]} {$i >= 0} {incr i -1} { + set r $row + lset r $i $fs + lset r end-$i $bs + #append onecross [::join $r ""] \n + lappend crossrows [::join $r ""] + } + #set onecross [tcl::string::trimright $onecross \n] + set onecross [::join $crossrows \n] + + #fastest to do row first then columns - because textblock::join must do line by line + + if {$crosscount > 1} { + set row [textblock::join -- {*}[lrepeat $crosscount $onecross]] + set rows [lrepeat $crosscount $row] + set out [::join $rows \n] + } else { + set out $onecross + } + + return $out + } + + #Test we can join two coloured blocks + proc test_colour {} { + set b1 [a red]1\n2\n3[a] + set b2 [a green]a\nb\nc[a] + set result [textblock::join -- $b1 $b2] + puts $result + #return [list $b1 $b2 $result] + return [ansistring VIEW $result] + } + tcl::namespace::import ::punk::ansi::ansistrip +} + + +tcl::namespace::eval ::textblock::piper { + tcl::namespace::export * + proc join {rhs pipelinedata} { + tailcall ::textblock::join -- $pipelinedata $rhs + } +} +interp alias {} piper_blockjoin {} ::textblock::piper::join + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide textblock [tcl::namespace::eval textblock { + variable version + set version 0.1.2 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/bootsupport/modules/zipper-0.11.tm b/src/bootsupport/modules/zipper-0.11.tm new file mode 100644 index 00000000..2f72c19e Binary files /dev/null and b/src/bootsupport/modules/zipper-0.11.tm differ diff --git a/src/bootsupport/modules/zipper-0.12.tm b/src/bootsupport/modules/zipper-0.12.tm new file mode 100644 index 00000000..6bf5e87e Binary files /dev/null and b/src/bootsupport/modules/zipper-0.12.tm differ diff --git a/src/make.tcl b/src/make.tcl index f6ade4c4..de7e055a 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -19,7 +19,7 @@ namespace eval ::punkboot { variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] variable non_help_flags [list -k] variable help_flags [list -help --help /?] - variable known_commands [list project modules info check shell vendorupdate bootsupport vfscommonupdate] + variable known_commands [list project modules vfs info check shell vendorupdate bootsupport vfscommonupdate] } @@ -302,6 +302,7 @@ set ::punkboot::bootsupport_requirements [dict create\ punk::ansi [list]\ overtype [list version "1.6.5-"]\ punkcheck [list]\ + fauxlink [list version "0.1.1-"]\ textblock [list version 0.1.1-]\ fileutil::traverse [list]\ md5 [list version 2-]\ @@ -1041,7 +1042,7 @@ proc ::punkboot::punkboot_gethelp {args} { append h " $scriptname vendorupdate" \n append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n append h " $scriptname vfscommonupdate" \n - append h " - update the src/vfs/_vfscommon from compiled src/modules and src/lib etc" \n + append h " - update the src/vfs/_vfscommon.vfs from compiled src/modules and src/lib etc" \n append h " - before calling this (followed by make project) - you can test using '(.exe) dev'" \n append h " this will load modules from your /module /lib paths instead of from the kit/zipkit" \n \n append h " $scriptname info" \n @@ -1332,22 +1333,22 @@ if {$::punkboot::command eq "shell"} { if {$::punkboot::command eq "vfscommonupdate"} { puts "projectroot: $projectroot" puts "script: [info script]" - puts stdout "Updating vfs/_vfscommon" + puts stdout "Updating vfs/_vfscommon.vfs" - puts stdout "REPLACE src/vfs/_vfscommon/* with project's modules and libs?? y|n" + puts stdout "REPLACE src/vfs/_vfscommon.vfs/* with project's modules and libs?? y|n" if {[gets stdin] eq "y"} { puts proceeding... proc vfscommonupdate {projectroot} { - file delete -force $projectroot/src/vfs/_vfscommon/modules - file copy $projectroot/modules $projectroot/src/vfs/_vfscommon/ + file delete -force $projectroot/src/vfs/_vfscommon.vfs/modules + file copy $projectroot/modules $projectroot/src/vfs/_vfscommon.vfs/ #temp? (avoid zipfs mkimg windows dotfile bug) - file delete $projectroot/src/vfs/_vfscommon/modules/.punkcheck + file delete $projectroot/src/vfs/_vfscommon.vfs/modules/.punkcheck - file delete -force $projectroot/src/vfs/_vfscommon/lib - file copy $projectroot/lib $projectroot/src/vfs/_vfscommon/ + file delete -force $projectroot/src/vfs/_vfscommon.vfs/lib + file copy $projectroot/lib $projectroot/src/vfs/_vfscommon.vfs/ #temp? - file delete $projectroot/src/vfs/_vfscommon/lib/.punkcheck + file delete $projectroot/src/vfs/_vfscommon.vfs/lib/.punkcheck } vfscommonupdate $projectroot @@ -1637,7 +1638,7 @@ if {$::punkboot::command eq "bootsupport"} { -if {$::punkboot::command ni {project modules}} { +if {$::punkboot::command ni {project modules vfs}} { puts stderr "Command $::punkboot::command not implemented - aborting." flush stderr after 100 @@ -1650,233 +1651,238 @@ if {$::punkboot::command ni {project modules}} { #install src vendor contents (from version controlled src folder) to base of project (same target folders as our own src/modules etc ie to paths that go on the auto_path and in tcl::tm::list) -set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] -lappend vendorlibfolders vendorlib -foreach lf $vendorlibfolders { - if {[file exists $sourcefolder/$lf]} { - lassign [split $lf _] _vm tclx - if {$tclx ne ""} { - set which _$tclx - } else { - set which "" - } - set target_lib_folder $projectroot/lib$which - file mkdir $projectroot/lib$which - #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g - # */test.txt will only match test.txt exactly one level deep. - # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. - # **/test.txt will match at any level below the root (but not in the root) - set antipaths [list\ - README.md\ - ] - puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] +if {$::punkboot::command in {project modules}} { + set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] + lappend vendorlibfolders vendorlib + foreach lf $vendorlibfolders { + if {[file exists $sourcefolder/$lf]} { + lassign [split $lf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set target_lib_folder $projectroot/lib$which + file mkdir $projectroot/lib$which + #exclude README.md from source folder - but only the root one + #-antiglob_paths takes relative patterns e.g + # */test.txt will only match test.txt exactly one level deep. + # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. + # **/test.txt will match at any level below the root (but not in the root) + set antipaths [list\ + README.md\ + ] + puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } + } + if {![llength $vendorlibfolders]} { + puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found." } -} -if {![llength $vendorlibfolders]} { - puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found." -} -set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] -lappend vendormodulefolders vendormodules + set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] + lappend vendormodulefolders vendormodules -foreach vf $vendormodulefolders { - if {[file exists $sourcefolder/$vf]} { - lassign [split $vf _] _vm tclx - if {$tclx ne ""} { - set which _$tclx - } else { - set which "" - } - set target_module_folder $projectroot/modules$which - file mkdir $target_module_folder + foreach vf $vendormodulefolders { + if {[file exists $sourcefolder/$vf]} { + lassign [split $vf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set target_module_folder $projectroot/modules$which + file mkdir $target_module_folder - #install .tm *and other files* - puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] + #install .tm *and other files* + puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } } -} -if {![llength $vendormodulefolders]} { - puts stderr "VENDORMODULES: No src/vendormodules or src/vendormodules_tcl* folders found." -} - -######################################################## -#templates -#e.g The default project layout is mainly folder structure and readme files - but has some scripts developed under the main src that we want to sync -#src to src/modules/punk/mix/templates/layouts/project/src - -set old_layout_update_list [list\ - [list project $sourcefolder/modules/punk/mix/templates]\ - [list basic $sourcefolder/mixtemplates]\ - ] -set layout_bases [list\ - $sourcefolder/project_layouts/custom/_project\ - ] - -foreach layoutbase $layout_bases { - if {![file exists $layoutbase]} { - continue + if {![llength $vendormodulefolders]} { + puts stderr "VENDORMODULES: No src/vendormodules or src/vendormodules_tcl* folders found." } - set project_layouts [glob -nocomplain -dir $layoutbase -type d -tail *] - foreach layoutname $project_layouts { - set config [dict create\ - -make-step sync_layouts\ - ] - #---------- - set tpl_installer [punkcheck::installtrack new make.tcl $layoutbase/.punkcheck] - $tpl_installer set_source_target $sourcefolder $layoutbase - set tpl_event [$tpl_installer start_event $config] - #---------- - set pairs [list] - set pairs [list\ - [list $sourcefolder/build.tcl $layoutbase/$layoutname/src/build.tcl]\ - [list $sourcefolder/make.tcl $layoutbase/$layoutname/src/make.tcl]\ - ] - foreach filepair $pairs { - lassign $filepair srcfile tgtfile + ######################################################## + #templates + #e.g The default project layout is mainly folder structure and readme files - but has some scripts developed under the main src that we want to sync + #src to src/modules/punk/mix/templates/layouts/project/src - file mkdir [file dirname $tgtfile] + set old_layout_update_list [list\ + [list project $sourcefolder/modules/punk/mix/templates]\ + [list basic $sourcefolder/mixtemplates]\ + ] + set layout_bases [list\ + $sourcefolder/project_layouts/custom/_project\ + ] + + foreach layoutbase $layout_bases { + if {![file exists $layoutbase]} { + continue + } + set project_layouts [glob -nocomplain -dir $layoutbase -type d -tail *] + foreach layoutname $project_layouts { + set config [dict create\ + -make-step sync_layouts\ + ] #---------- - $tpl_event targetset_init INSTALL $tgtfile - $tpl_event targetset_addsource $srcfile + set tpl_installer [punkcheck::installtrack new make.tcl $layoutbase/.punkcheck] + $tpl_installer set_source_target $sourcefolder $layoutbase + set tpl_event [$tpl_installer start_event $config] #---------- - if {\ - [llength [dict get [$tpl_event targetset_source_changes] changed]]\ - || [llength [$tpl_event get_targets_exist]] < [llength [$tpl_event get_targets]]\ - } { - $tpl_event targetset_started - # -- --- --- --- --- --- - puts stdout "PROJECT LAYOUT update - layoutname: $layoutname Copying from $srcfile to $tgtfile" - if {[catch { - file copy -force $srcfile $tgtfile - } errM]} { - $tpl_event targetset_end FAILED -note "layout:$layoutname copy failed with err: $errM" + set pairs [list] + set pairs [list\ + [list $sourcefolder/build.tcl $layoutbase/$layoutname/src/build.tcl]\ + [list $sourcefolder/make.tcl $layoutbase/$layoutname/src/make.tcl]\ + ] + + foreach filepair $pairs { + lassign $filepair srcfile tgtfile + + file mkdir [file dirname $tgtfile] + #---------- + $tpl_event targetset_init INSTALL $tgtfile + $tpl_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$tpl_event targetset_source_changes] changed]]\ + || [llength [$tpl_event get_targets_exist]] < [llength [$tpl_event get_targets]]\ + } { + $tpl_event targetset_started + # -- --- --- --- --- --- + puts stdout "PROJECT LAYOUT update - layoutname: $layoutname Copying from $srcfile to $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $tpl_event targetset_end FAILED -note "layout:$layoutname copy failed with err: $errM" + } else { + $tpl_event targetset_end OK -note "layout:$layoutname" + } + # -- --- --- --- --- --- } else { - $tpl_event targetset_end OK -note "layout:$layoutname" + puts stderr "." + $tpl_event targetset_end SKIPPED } - # -- --- --- --- --- --- - } else { - puts stderr "." - $tpl_event targetset_end SKIPPED } - } - $tpl_event end - $tpl_event destroy - $tpl_installer destroy + $tpl_event end + $tpl_event destroy + $tpl_installer destroy + } } -} -######################################################## -set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] -lappend projectlibfolders lib -foreach lf $projectlibfolders { - if {[file exists $sourcefolder/$lf]} { - lassign [split $lf _] _vm tclx - if {$tclx ne ""} { - set which _$tclx + ######################################################## + set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] + lappend projectlibfolders lib + foreach lf $projectlibfolders { + if {[file exists $sourcefolder/$lf]} { + lassign [split $lf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set target_lib_folder $projectroot/lib$which + file mkdir $projectroot/lib$which + #exclude README.md from source folder - but only the root one + #-antiglob_paths takes relative patterns e.g + # */test.txt will only match test.txt exactly one level deep. + # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. + # **/test.txt will match at any level below the root (but not in the root) + set antipaths [list\ + README.md\ + ] + puts stdout "PROJECTLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } + } + if {![llength $projectlibfolders]} { + puts stderr "PROJECTLIB: No src/lib or src/lib_tcl* folder found." + } + + #consolidated /modules /modules_tclX folder used for target where X is tcl major version + #the make process will process for any _tclX not just the major version of the current interpreter + + #default source module folders are at projectroot/src/modules and projectroot/src/modules_tclX (where X is tcl major version) + #There may be multiple other src module folders at same level (e.g folder not being other special-purpose folder and not matching name vendor* that contains at least one .tm file in its root) + set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] + puts stdout "SOURCEMODULES: scanning [llength $source_module_folderlist] folders" + foreach src_module_dir $source_module_folderlist { + set mtail [file tail $src_module_dir] + if {[string match "modules_tcl*" $mtail]} { + set target_modules_base $projectroot/$mtail } else { - set which "" - } - set target_lib_folder $projectroot/lib$which - file mkdir $projectroot/lib$which - #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g - # */test.txt will only match test.txt exactly one level deep. - # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. - # **/test.txt will match at any level below the root (but not in the root) - set antipaths [list\ - README.md\ - ] - puts stdout "PROJECTLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + set target_modules_base $projectroot/modules + } + file mkdir $target_modules_base + + puts stderr "Processing source module dir: $src_module_dir" + set dirtail [file tail $src_module_dir] + #modules and associated files belonging to this package/app + set copied [punk::mix::cli::lib::build_modules_from_source_to_base $src_module_dir $target_modules_base -glob *.tm] ;#will only accept a glob ending in .tm + #set copied [list] + puts stdout "--------------------------" + puts stderr "Copied [llength $copied] tm modules from src/$dirtail to $target_modules_base " + puts stdout "--------------------------" + + set overwrite "installedsourcechanged-targets" + #set overwrite "ALL-TARGETS" + puts stdout "MODULEFOLDER non_tm_files $src_module_dir - copying to $target_modules_base (if source file changed)" + set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base -installer make.tcl -overwrite $overwrite -antiglob_paths {README.md}] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } -} -if {![llength $projectlibfolders]} { - puts stderr "PROJECTLIB: No src/lib or src/lib_tcl* folder found." -} -#consolidated /modules /modules_tclX folder used for target where X is tcl major version -#the make process will process for any _tclX not just the major version of the current interpreter - -#default source module folders are at projectroot/src/modules and projectroot/src/modules_tclX (where X is tcl major version) -#There may be multiple other src module folders at same level (e.g folder not being other special-purpose folder and not matching name vendor* that contains at least one .tm file in its root) -set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] -puts stdout "SOURCEMODULES: scanning [llength $source_module_folderlist] folders" -foreach src_module_dir $source_module_folderlist { - set mtail [file tail $src_module_dir] - if {[string match "modules_tcl*" $mtail]} { - set target_modules_base $projectroot/$mtail - } else { - set target_modules_base $projectroot/modules - } - file mkdir $target_modules_base - - puts stderr "Processing source module dir: $src_module_dir" - set dirtail [file tail $src_module_dir] - #modules and associated files belonging to this package/app - set copied [punk::mix::cli::lib::build_modules_from_source_to_base $src_module_dir $target_modules_base -glob *.tm] ;#will only accept a glob ending in .tm - #set copied [list] - puts stdout "--------------------------" - puts stderr "Copied [llength $copied] tm modules from src/$dirtail to $target_modules_base " - puts stdout "--------------------------" - - set overwrite "installedsourcechanged-targets" - #set overwrite "ALL-TARGETS" - puts stdout "MODULEFOLDER non_tm_files $src_module_dir - copying to $target_modules_base (if source file changed)" - set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base -installer make.tcl -overwrite $overwrite -antiglob_paths {README.md}] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] -} - -set installername "make.tcl" + set installername "make.tcl" -# ---------------------------------------- -if {[punk::repo::is_fossil_root $projectroot]} { - set config [dict create\ - -make-step configure_fossil\ - ] - #---------- - set installer [punkcheck::installtrack new $installername $projectroot/.punkcheck] - $installer set_source_target $projectroot $projectroot + # ---------------------------------------- + if {[punk::repo::is_fossil_root $projectroot]} { + set config [dict create\ + -make-step configure_fossil\ + ] + #---------- + set installer [punkcheck::installtrack new $installername $projectroot/.punkcheck] + $installer set_source_target $projectroot $projectroot - set event [$installer start_event $config] - $event targetset_init VIRTUAL fossil_settings_mainmenu ;#VIRTUAL - since there is no actual target file - set menufile $projectroot/.fossil-custom/mainmenu - $event targetset_addsource $menufile - #---------- + set event [$installer start_event $config] + $event targetset_init VIRTUAL fossil_settings_mainmenu ;#VIRTUAL - since there is no actual target file + set menufile $projectroot/.fossil-custom/mainmenu + $event targetset_addsource $menufile + #---------- - if {\ - [llength [dict get [$event targetset_source_changes] changed]]\ - } { - $event targetset_started - # -- --- --- --- --- --- - puts stdout "Configuring fossil setting: mainmenu from: $menufile" - if {[catch { - set fd [open $menufile r] - fconfigure $fd -translation binary - set data [read $fd] - close $fd - exec fossil settings mainmenu $data - } errM]} { - $event targetset_end FAILED -note "fossil update failed: $errM" + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + } { + $event targetset_started + # -- --- --- --- --- --- + puts stdout "Configuring fossil setting: mainmenu from: $menufile" + if {[catch { + set fd [open $menufile r] + fconfigure $fd -translation binary + set data [read $fd] + close $fd + exec fossil settings mainmenu $data + } errM]} { + $event targetset_end FAILED -note "fossil update failed: $errM" + } else { + $event targetset_end OK + } + # -- --- --- --- --- --- } else { - $event targetset_end OK + puts stderr "." + $event targetset_end SKIPPED } - # -- --- --- --- --- --- - } else { - puts stderr "." - $event targetset_end SKIPPED + $event end + $event destroy + $installer destroy } - $event end - $event destroy - $installer destroy } -if {$::punkboot::command ne "project"} { +#review +set installername "make.tcl" + +if {$::punkboot::command ni {project vfs}} { #command = modules puts stdout "vfs folders not checked" puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into base vfs folder" @@ -2099,7 +2105,8 @@ foreach runtimefile $runtimes { } { $event targetset_started # -- --- --- --- --- --- - puts stdout "Copying runtime from $rtfolder/$runtimefile to $buildfolder/build_$runtimefile" + #This is the full runtime - *possibly* with some sort of vfs attached. + puts stdout "Copying runtime (as is) from $rtfolder/$runtimefile to $buildfolder/build_$runtimefile" if {[catch { file copy -force $rtfolder/$runtimefile $buildfolder/build_$runtimefile ;#becomes building_runtime } errM]} { @@ -2126,21 +2133,27 @@ set skipped_kit_installs [list] proc ::make_file_traversal_error {args} { error "file_traverse error: $args" } -proc merge_over {sourcedir targetdir} { + +#fauxlink aware recursive copy of files and folders +#will follow fauxlinks with 'merge_over' tag, will copy other fauxlinks +proc merge_over {sourcedir targetdir {depth 0}} { package require fileutil + package require fauxlink + set margin [string repeat " " [expr {$depth * 4}]] + set ver [package require fileutil::traverse] - puts stdout "using fileutil::traverse $ver\n[package ifneeded fileutil::traverse $ver]" + puts stdout "${margin}using fileutil::traverse $ver\n[package ifneeded fileutil::traverse $ver]" package require control if {![file exists $sourcedir]} { - puts stderr "merge_over sourcedir '$sourcedir' not found" + puts stderr "${margin}merge_over sourcedir '$sourcedir' not found" return } if {![file exists $targetdir]} { - puts stderr "merge_over targetdir '$targetdir' not found - target folder must already exist" + puts stderr "${margin}merge_over targetdir '$targetdir' not found - target folder must already exist" return } - puts stdout "merge vfs $sourcedir over $targetdir STARTING" + puts stdout "${margin}merge vfs $sourcedir over $targetdir STARTING" #The tails should be unique enough for clarity in progress emissions to stdout set sourcename [file tail $sourcedir] @@ -2159,7 +2172,7 @@ proc merge_over {sourcedir targetdir} { } if {![file exists $target]} { #puts stdout "-- mkdir $target" - puts stdout "$sourcename -> $targetname mkdir $relpath" + puts stdout "${margin}$sourcename -> $targetname mkdir $relpath" #puts stdout "calling: file mkdir $target" #note - file mkdir can fail on vfs mounts with non-existant intermediate paths. #e.g if mount is at: //cookfstemp:/subpath/file.exe @@ -2168,21 +2181,74 @@ proc merge_over {sourcedir targetdir} { file mkdir $target file mtime $target [file mtime $file_or_dir] } else { - puts stdout "$sourcename -> $targetname existing dir $relpath" + puts stdout "${margin}$sourcename -> $targetname existing dir $relpath" } } file { - puts -nonewline stdout "." - file copy -force $file_or_dir $target + if {[file extension $file_or_dir] in {.fxlnk .fauxlink}} { + puts stdout "fauxlink: $file_or_dir" + flush stdout + if {[catch { + puts stdout ">";flush stdout + set linkinfo [fauxlink::resolve $file_or_dir] + } errM]} { + puts stdout ">>";flush stdout + puts stdout "${margin}--->fauxlink::resolve error\n $errM" + flush stdout + error $errM + } + puts stdout ">>>";flush stdout + puts stdout "--- '$linkinfo'" + flush stdout + set flinktags [dict get $linkinfo tags] + puts stdout "fauxlink tags: $flinktags" + flush stdout + if {"punk::boot,merge_over" in $flinktags} { + puts stdout "fauxlink got correct tag from $flinktags" + flush stdout + set linktarget [dict get $linkinfo targetpath] + if {[file pathtype $linktarget] eq "relative"} { + set actualsource [file join $sourcedir $linktarget] + } else { + set actualsource $linktarget + } + set name [dict get $linkinfo name] ;#name the linked file will become + set aliased_file_or_dir [file join [file dirname $file_or_dir] $name] + set relpath [fileutil::stripPath $sourcedir $aliased_file_or_dir] + set target [file join $targetdir $relpath] + if {[file type $actualsource] eq "file"} { + #fauxlink linktarget (source data) is a file + puts -nonewline stdout "\x1b\[32m\x1b\[m" + #puts "file copy -force $actualsource $target" + file copy -force $actualsource $target + } else { + #fauxlink linktarget (source data) is a folder + puts stdout "${margin}RECURSING merge_over for link-target $actualsource due to fauxlink:[file tail $file_or_dir]" + #merge_over initial target dir must exist - use file mkdir to ensure + file mkdir $target + puts stdout "merge_over $actualsource $target [expr {$depth + 1}]" + merge_over $actualsource $target [expr {$depth + 1}] + } + } else { + puts stdout "fauxlink tag not matched" + flush stdout + #tag not targetted at us - just copy the fauxlink as an ordinary file + puts -nonewline stdout "" + file copy -force $file_or_dir $target + } + } else { + puts -nonewline stdout "." + file copy -force $file_or_dir $target + } } default { - puts stderr "merge vfs $sourcedir !!! unhandled file type $this_type !!!" + puts stderr "${margin}merge vfs $sourcedir !!! unhandled file type $this_type !!!" } } set last_type $this_type } $t destroy - puts stdout "\nmerge vfs $sourcedir over $targetdir done." + puts stdout "\n${margin}merge vfs $sourcedir over $targetdir done." } set startdir [pwd] puts stdout "Found [llength $vfs_tails] .vfs folders - checking each for executables that may need to be built" @@ -2193,7 +2259,7 @@ cd [file dirname $buildfolder] #Using first mtime encountered that is later than target is another option - but likely to be highly variable in speed. Last file in the tree could happen to be the latest, and this mechanism doesn't handle build on reversion to older source. set exe_names_seen [list] set path_cksum_cache [dict create] -dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/_vfscommon] +dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/_vfscommon.vfs] # # loop over vfs_tails and for each one, loop over configured (or matching) runtimes - build with sdx or zipfs if source .vfs or source runtime exe has changed. @@ -2305,13 +2371,16 @@ foreach vfstail $vfs_tails { dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/$vfstail] } $vfs_event targetset_cksumcache_set $path_cksum_cache ;#cached cksum entries for .vfs folder - $vfs_event targetset_addsource $sourcefolder/vfs/_vfscommon + $vfs_event targetset_addsource $sourcefolder/vfs/_config ;#some files linked via fauxlink - need to detect change + $vfs_event targetset_addsource $sourcefolder/vfs/_vfscommon.vfs $vfs_event targetset_addsource $sourcefolder/vfs/$vfstail if {$rtname ne "-"} { - set building_runtime $buildfolder/build_$runtime_fullname ;#working copy of runtime executable + set building_runtime $buildfolder/build_$runtime_fullname ;#working copy of runtime executable - (possibly with kit/zipfs/cookfs etc attached!) $vfs_event targetset_addsource $building_runtime + set raw_runtime "" ;#building runtime with vfs (zip,kit,cookfs etc stripped) } else { set building_runtime "-" ;#REVIEW + set raw_runtime "-" } # -- ---------- @@ -2333,7 +2402,8 @@ foreach vfstail $vfs_tails { package require fileutil::traverse package require control - set targetvfs $buildfolder/buildvfs_$targetkit.vfs + #keep this a simple name - bin/punk script calls into src/_build/exename.vfs/main.tcl + set targetvfs $buildfolder/$targetkit.vfs file delete -force $targetvfs #we switch on the target kit_type. we could switch on source kit_type..allowing extraction from one type but writing to another? @@ -2344,7 +2414,7 @@ foreach vfstail $vfs_tails { #would need to detect UPX, cookfs,zipfs,tclkit set rtmountpoint "" switch -- $kit_type { - zip { + zip - zipcat { #for a zipkit - we need to extract the existing vfs from the runtime #zipfs mkimg replaces the entire zipped vfs in the runtime - so we need the original data to be part of our targetvfs. puts stdout "building $vfsname.new with zipfs vfsdir:$vfstail cwd: [pwd]" @@ -2364,11 +2434,44 @@ foreach vfstail $vfs_tails { } } + #strip any existing zipfs on the runtime.. + #2024 - 'zipfs info //zipfs:/mountpoint' is supposed to give us the offset - but it doesn't if the exe has been 'adjusted' to use file offsets. + #which unfortunately Tcl does by default after the 2021 'fix' :( + #https://core.tcl-lang.org/tcl/tktview/aaa84fbbc5 + + set raw_runtime $buildfolder/raw_$runtime_fullname if {[file exists $rtmountpoint]} { merge_over $rtmountpoint $targetvfs + #see if we can extract the exe part + set baseoffset [lindex [tcl::zipfs::info $rtmountpoint] 3] + if {$baseoffset != 0} { + #tcl was able to determine the compressed-data offset + #either because runtime is a basic catted exe+zip, or Tcl fixed 'zipfs info' + set fdrt [open $building_runtime r] + chan configure $fdrt -translation binary + set exedata [read $fdrt $baseoffset] ;#may include stored password and ending header // REVIEW - strip it? + close $fdrt + set fdraw [open $raw_runtime w] + chan configure $fdraw -translation binary + puts -nonewline $fdraw $exedata + close $fdraw + } else { + #presumably the supplied building_runtime has had its offsets adjusted so that it all appears within offsets off the zip. (file relative offsets) + #due to zipfs info bug - zipfs now can't tell us the offset of the compressed data. + #we need to use a similarly assumptive method as tclZipfs.c uses to determine the start of the compressed contents + package require punk::zip + #we don't technically need to extract the raw exe for 'zip' - as zipfs mkimg can work on the combined file (ignores zip) + # - but for consistency we want raw_runtime to be emitted in the filesystem. + punk::zip::extract_preamble $building_runtime $raw_runtime + } + } else { + #the input building_runtime wasn't mountable - so presumably a plain executable + #set building_runtime $buildfolder/build_$runtime_fullname ;#working copy of runtime executable - (possibly with kit/zipfs/cookfs etc attached!) + #set raw_runtime $buildfolder/raw_$runtime_fullname + file copy -force $building_runtime $raw_runtime } - merge_over $sourcefolder/vfs/_vfscommon $targetvfs + merge_over $sourcefolder/vfs/_vfscommon.vfs $targetvfs } cookit - cookfs { @@ -2396,15 +2499,15 @@ foreach vfstail $vfs_tails { #copy from mounted runtime's vfs to the filesystem vfs merge_over $rtmountpoint $targetvfs } - merge_over $sourcefolder/vfs/_vfscommon $targetvfs + merge_over $sourcefolder/vfs/_vfscommon.vfs $targetvfs } } kit { #for a kit, we don't need to extract the existing vfs from the runtime. # - the sdx merge process can merge our .vfs folder with the existing contents. puts stdout "building $vfsname.new with sdx.. vfsdir:$vfstail cwd: [pwd]" - if {[file exists $sourcefolder/vfs/_vfscommon]} { - file copy $sourcefolder/vfs/_vfscommon $targetvfs + if {[file exists $sourcefolder/vfs/_vfscommon.vfs]} { + file copy $sourcefolder/vfs/_vfscommon.vfs $targetvfs } else { file mkdir $targetvfs } @@ -2420,6 +2523,15 @@ foreach vfstail $vfs_tails { set wrapvfs $targetvfs switch -- $kit_type { zip { + #WARNING - 2024-10-08 - zipfs mkimg based exezips are not editable with 7z + # (central directory offset has been 'adjusted' to be file relative) + #This makes finding the split between prefixed exe and zip-data harder for Tcl scripts + #- although zipfs mkimg does it in a somewhat wonky way. + #tclZipfs.c as at 2024 assumes first file header in the CDR points to first local file header and assumes that is the top of the zipdata. + #This is only *mostly* true. order of entries or completeness is not guaranteed. + #e.g topmost file data in zip may not be pointed to if deleted by certain tools. + #for files created by zipfs mkimg and not externally edited - it shouldn't be an issue though. + if {$rtname eq "-"} { #todo - just make a zip? error "runtime name of - unsupported for zip - (todo)" @@ -2436,8 +2548,8 @@ foreach vfstail $vfs_tails { } } #note - as at 2024-08 - there is some discussion about the interface to mkimg - it is considered unstable (may change to -option value syntax) - puts stderr "calling: tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs \"\" $building_runtime" - tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs "" $building_runtime + puts stderr "calling: tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs \"\" $raw_runtime" + tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs "" $raw_runtime } result ]} { set failmsg "zipfs mkimg failed with msg: $result" puts stderr "tcl::zipfs::mkimg $targetkit failed" @@ -2453,6 +2565,67 @@ foreach vfstail $vfs_tails { puts stdout $result puts stdout $separator } + } + zipcat { + #simple catenated runtime + zip - we need an exe runtime with no zipfs attached.. + if {$rtname eq "-"} { + #todo - just make a zip? + error "runtime name of - unsupported for zip - (todo)" + } + if {[catch { + if {[dict exists $runtime_caps $rtname]} { + if {[dict get $runtime_caps $rtname exitcode] == 0} { + if {![dict get $runtime_caps $rtname has_zipfs]} { + error "runtime $rtname doesn't have zipfs capability" + } + } else { + #could be runtime for another platform + puts stderr "RUNTIME capabilities unknown. Unsure if zip supported. trying anyway.." + } + } + + #'archive' based zip offsets - editable in 7z,peazip + file copy $raw_runtime $buildfolder/$vfsname.new + file delete $buildfolder/$vfsname.zip + + if {[info commands ::tcl::zipfs] ne ""} { + puts stdout "tcl::zipfs::mkzip $buildfolder/$vfsname.zip $wrapvfs $wrapvfs" + ::tcl::zipfs::mkzip $buildfolder/$vfsname.zip $wrapvfs $wrapvfs + } else { + puts stdout "punk::zip::mkzip -directory $wrapvfs -base $wrapvfs $buildfolder/$vfsname.zip *" + package require punk::zip + punk::zip::mkzip -directory $wrapvfs -base $wrapvfs $buildfolder/$vfsname.zip * + } + + + puts stderr "concatenating executable to zip.." + set fdout [open $buildfolder/$vfsname.new a] + chan conf $fdout -translation binary + puts stderr "runtime bytes: [tell $fdout]" + set fdzip [open $buildfolder/$vfsname.zip r] + chan conf $fdzip -translation binary + set zipbytes [fcopy $fdzip $fdout] + close $fdzip + puts stderr "zip bytes: $zipbytes" + puts stderr "exezip bytes: [tell $fdout]" + close $fdout + } result ]} { + set failmsg "creating zipcat image failed with msg: $result" + puts stderr "creating image (zipcat) $targetkit failed" + lappend failed_kits [list kit $targetkit reason $failmsg] + $vfs_event targetset_end FAILED + $vfs_event destroy + $vfs_installer destroy + continue + } else { + puts stdout "ok - finished zipcat image" + set separator [string repeat = 40] + puts stdout $separator + puts stdout $result + puts stdout $separator + } + + } cookit - cookfs { if {$rtmountpoint eq ""} { @@ -2509,17 +2682,20 @@ foreach vfstail $vfs_tails { $vfs_installer destroy continue } else { + set verbose "" + #set verbose "-verbose" + if {[catch { if {$rtname ne "-"} { - exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $building_runtime -verbose + exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $building_runtime {*}$verbose } else { - exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose + exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs {*}$verbose } } result]} { if {$rtname ne "-"} { - set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose failed with msg: $result" + set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname {*}$verbose failed with msg: $result" } else { - set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose failed with msg: $result" + set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs {*}$verbose failed with msg: $result" } puts stderr "sdx wrap $targetkit failed" lappend failed_kits [list kit $targetkit reason $sdxmsg] @@ -2722,9 +2898,9 @@ set had_kits [expr {[llength $installed_kits] || [llength $failed_kits] || [llen if {$had_kits} { puts stdout " module builds and kit/zipkit builds processed (vfs config: src/runtime/mapvfs.config)" puts stdout " - use 'make.tcl modules' to build modules without scanning/building the vfs folders into executable kits/zipkits" - puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into the base vfs folder" - puts stdout " Note that without the vfscommonupdate step, 'make.tcl project' will include any manual changes in the *custom* vfs folders but" - puts stdout " without the latest built modules." + puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into the base vfs folder /src/vfs/_vfscommon.vfs" + puts stdout " - Note that without the vfscommonupdate step, 'make tcl vfs' (included in 'make tcl project') will build vfs based executables" + puts stdout " that include your current custom vfs folders in src/vfs, but with a _vfscommon.vfs that doesn't have the latest built modules" puts stdout " calling 'builtexename(.exe) dev' will allow testing of built modules before they are put into the kits/zipkits via 'vfscommonupdate' then 'project'" } else { puts stdout " module builds processed" diff --git a/src/modules/#modpod-zipper-0.11/zipper-0.11.tm b/src/modules/#modpod-zipper-0.11/zipper-0.11.tm deleted file mode 100644 index 2e9b8baa..00000000 --- a/src/modules/#modpod-zipper-0.11/zipper-0.11.tm +++ /dev/null @@ -1,120 +0,0 @@ -# ZIP file constructor - -package provide zipper 0.11 - -namespace eval zipper { - namespace export initialize addentry finalize - - namespace eval v { - variable fd - variable base - variable toc - } - - proc initialize {fd} { - set v::fd $fd - set v::base [tell $fd] - set v::toc {} - fconfigure $fd -translation binary -encoding binary - } - - proc emit {s} { - puts -nonewline $v::fd $s - } - - proc dostime {sec} { - set f [clock format $sec -format {%Y %m %d %H %M %S} -gmt 1] - regsub -all { 0(\d)} $f { \1} f - foreach {Y M D h m s} $f break - set date [expr {(($Y-1980)<<9) | ($M<<5) | $D}] - set time [expr {($h<<11) | ($m<<5) | ($s>>1)}] - return [list $date $time] - } - - proc addentry {name contents {date ""} {force 0}} { - if {$date == ""} { set date [clock seconds] } - foreach {date time} [dostime $date] break - set flag 0 - set type 0 ;# stored - set fsize [string length $contents] - set csize $fsize - set fnlen [string length $name] - - if {$force > 0 && $force != [string length $contents]} { - set csize $fsize - set fsize $force - set type 8 ;# if we're passing in compressed data, it's deflated - } - - if {[catch { zlib crc32 $contents } crc]} { - set crc 0 - } elseif {$type == 0} { - set cdata [zlib deflate $contents] - if {[string length $cdata] < [string length $contents]} { - set contents $cdata - set csize [string length $cdata] - set type 8 ;# deflate - } - } - - lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \ - $flag $type $time $date $crc $csize $fsize $fnlen \ - {0 0 0 0} 128 [tell $v::fd]]$name" - - emit [binary format a2c4ssssiiiss PK {3 4 20 0} \ - $flag $type $time $date $crc $csize $fsize $fnlen 0] - emit $name - emit $contents - } - - proc finalize {} { - set pos [tell $v::fd] - - set ntoc [llength $v::toc] - foreach x $v::toc { emit $x } - set v::toc {} - - set len [expr {[tell $v::fd] - $pos}] - incr pos -$v::base - - emit [binary format a2c2ssssiis PK {5 6} 0 0 $ntoc $ntoc $len $pos 0] - - return $v::fd - } -} - -if {[info exists pkgtest] && $pkgtest} { - puts "no test code" -} - -# test code below runs when this is launched as the main script -if {[info exists argv0] && [string match zipper-* [file tail $argv0]]} { - - catch { package require zlib } - - zipper::initialize [open try.zip w] - - set dirs [list .] - while {[llength $dirs] > 0} { - set d [lindex $dirs 0] - set dirs [lrange $dirs 1 end] - foreach f [lsort [glob -nocomplain [file join $d *]]] { - if {[file isfile $f]} { - regsub {^\./} $f {} f - set fd [open $f] - fconfigure $fd -translation binary -encoding binary - zipper::addentry $f [read $fd] [file mtime $f] - close $fd - } elseif {[file isdir $f]} { - lappend dirs $f - } - } - } - - close [zipper::finalize] - - puts "size = [file size try.zip]" - puts [exec unzip -v try.zip] - - file delete try.zip -} 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 new file mode 100644 index 00000000..d15942ae --- /dev/null +++ b/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm @@ -0,0 +1,196 @@ +# ZIP file constructor + +package provide zipper 999999.0a1.0 + +namespace eval zipper { + namespace export initialize addentry adddir finalize + + namespace eval v { + variable fd + variable base + variable toc + } + + #if we initialize before writing anything to fd - our base is the file base + # - ie we get an 'internal preamble' + #if instead, we write data to fd before initialize, our base is the start of the archive-data. + # - ie we get an 'external preamble' + #Either way can work - but some zip utilities expect the base to always be the start of the file, + #others are able to process the external preamble. + #If the filename has the .zip extension - there should be no external preamble + #(utils may follow a different codepath for files with different extensions) + # + #It seems to be ok either way for reading - but some tools cannot write to file based offset if there is prefix data + #(e.g file.kit with offset adjusted with something like zip -A which makes the preamble internal to the zip) + # and some cannot write to archive-based offset if there is prefix data ! + #(e.g file.kit with preamble prepended and offsets not adjusted = external preamble) + # + #Some tools may auto-adjust to file-based offset when adding entries (e.g pkzip if extension is .zip) + + proc initialize {fd} { + set v::fd $fd + set v::base [tell $fd] + set v::toc {} + #fconfigure $fd -translation binary -encoding binary + fconfigure $fd -translation binary -encoding iso8859-1 + } + + proc emit {s} { + puts -nonewline $v::fd $s + } + + proc dostime {sec {gmt 0}} { + set f [clock format $sec -format {%Y %m %d %H %M %S} -gmt $gmt] + regsub -all { 0(\d)} $f { \1} f + foreach {Y M D h m s} $f break + set date [expr {(($Y-1980)<<9) | ($M<<5) | $D}] + set time [expr {($h<<11) | ($m<<5) | ($s>>1)}] + return [list $date $time] + } + + proc addentry {name contents {unixmtime ""} {force 0}} { + if {$unixmtime == ""} { set unixmtime [clock seconds] } + #lassign [dostime $date 1] date time ;#UTC would probably be more sensible - but convention seems to be localtime :/ + lassign [dostime $unixmtime 0] date time + set flag 0 + set type 0 ;# stored + set fsize [string length $contents] + set csize $fsize + set fnlen [string length $name] + + if {$force > 0 && $force != [string length $contents]} { + set csize $fsize + set fsize $force + set type 8 ;# if we're passing in compressed data, it's deflated + } + + if {[catch { zlib crc32 $contents } crc]} { + set crc 0 + } elseif {$type == 0} { + set cdata [zlib deflate $contents] + if {[string length $cdata] < [string length $contents]} { + set contents $cdata + set csize [string length $cdata] + set type 8 ;# deflate + } + } + #we are at the position to write a *local* file header (record including file data, and often with some duplication of data in corresponding CDR 'file header' - prior to CDR records) + #use the position to calculate the offset for the corresponding CDR file header + # -- --- --- --- --- --- --- + set local_file_relative_offset [expr {[tell $v::fd] -$v::base}] + #toc / File header within Central directory structure + #PK\1\2 - 0x02014b50 + #lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \ + # $flag $type $time $date $crc $csize $fsize $fnlen \ + # {0 0 0 0} 128 [tell $v::fd]]$name" + #build the CDR file header - but we don't add it here + set do_extended_timestamp 1 + if {!$do_extended_timestamp} { + lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \ + $flag $type $time $date $crc $csize $fsize $fnlen \ + {0 0 0 0} 128 $local_file_relative_offset]$name" + } else { + set extra "" + # --- + # Value Size Description + # ----- ---- ----------- + #(time) 0x5455 Short tag for this extra block type ("UT") + # TSize Short total data size for this block + # Flags Byte info bits (refers to local header!) + # (ModTime) Long time of last modification (UTC/GMT) + # --- + # - Tsize = 9 - 4 = 5 + set extended_timestamp [binary format a2sci UT 5 0 $unixmtime] + append extra $extended_timestamp + # --- + + set extralen [string length $extra] + lappend v::toc "[binary format a2c6ssssiiisss3ii PK {1 2 20 0 20 0} \ + $flag $type $time $date $crc $csize $fsize $fnlen \ + $extralen {0 0 0} 128 $local_file_relative_offset]$name$extra" + } + # -- --- --- --- --- --- --- + + #*Local* File Header PK\3\4 = 0x04034b50 (this is outside of and prior to CDR) + emit [binary format a2c4ssssiiiss PK {3 4 20 0} \ + $flag $type $time $date $crc $csize $fsize $fnlen 0] + emit $name + emit $contents + } + + proc adddir {name {date ""} {force 0}} { + set name "${name}/" + if {$date == ""} { set date [clock seconds] } + lassign [dostime $date 0] date time + set flag 0 + set type 0 ;# stored + set fsize 0 + set csize 0 + set fnlen [string length $name] + + set crc 0 + + lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \ + $flag $type $time $date $crc $csize $fsize $fnlen \ + {0 0 0 0} 128 [tell $v::fd]]$name" + + emit [binary format a2c4ssssiiiss PK {3 4 20 0} \ + $flag $type $time $date $crc $csize $fsize $fnlen 0] + emit $name + } + + proc finalize {} { + set cd_start_pos [tell $v::fd] + + set ntoc [llength $v::toc] + foreach x $v::toc { emit $x } + set v::toc {} + + set cd_end_pos [tell $v::fd] + + set len [expr {$cd_end_pos - $cd_start_pos}] + #incr pos -$v::base + set cdr_offset_pos [expr $cd_start_pos -$v::base] ;#review + #EOCD signature PK\5\6 = 0x06054b50 + emit [binary format a2c2ssssiis PK {5 6} 0 0 $ntoc $ntoc $len $cdr_offset_pos 0] + + return $v::fd + } +} + +if {[info exists pkgtest] && $pkgtest} { + puts "no test code" +} + +# test code below runs when this is launched as the main script +if {[info exists argv0] && [string match zipper-* [file tail $argv0]]} { + + #2024 - zlib should generally be builtin.. + catch { package require zlib } + + zipper::initialize [open try.zip w] + + set dirs [list .] + while {[llength $dirs] > 0} { + set d [lindex $dirs 0] + set dirs [lrange $dirs 1 end] + foreach f [lsort [glob -nocomplain [file join $d *]]] { + if {[file isfile $f]} { + regsub {^\./} $f {} f + set fd [open $f] + fconfigure $fd -translation binary -encoding binary + zipper::addentry $f [read $fd] [file mtime $f] + close $fd + } elseif {[file isdir $f]} { + lappend dirs $f + } + } + } + + close [zipper::finalize] + + puts "size = [file size try.zip]" + puts [exec unzip -v try.zip] + + file delete try.zip +} diff --git a/src/modules/#modpod-zipper-0.11/zipper.README b/src/modules/#modpod-zipper-999999.0a1.0/zipper.README similarity index 100% rename from src/modules/#modpod-zipper-0.11/zipper.README rename to src/modules/#modpod-zipper-999999.0a1.0/zipper.README diff --git a/src/modules/canaryspace-buildversion.txt b/src/modules/canaryspace-buildversion.txt index f47d01c8..7eeee9b0 100644 --- a/src/modules/canaryspace-buildversion.txt +++ b/src/modules/canaryspace-buildversion.txt @@ -1,3 +1,3 @@ 0.1.0 -#First line must be a semantic version number +#First line must be a tm version number #all other lines are ignored. diff --git a/src/modules/modpodtest-buildversion.txt b/src/modules/modpodtest-buildversion.txt index f47d01c8..7eeee9b0 100644 --- a/src/modules/modpodtest-buildversion.txt +++ b/src/modules/modpodtest-buildversion.txt @@ -1,3 +1,3 @@ 0.1.0 -#First line must be a semantic version number +#First line must be a tm version number #all other lines are ignored. diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index f65edd8d..7dd722ce 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -268,6 +268,34 @@ tcl::namespace::eval punk::args { #[list_begin definitions] + if {[info commands ::tcl::dict::getdef] eq ""} { + #package require punk::lib + #interp alias "" ::punk::args::Dict_getdef "" ::punk::lib::dict_getdef + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + #todo? -synonym ? (applies to opts only not values) #e.g -background -synonym -bg -default White @@ -339,10 +367,26 @@ tcl::namespace::eval punk::args { } #puts "indent1:[ansistring VIEW $lastindent]" set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } foreach rawline $linelist { set recordsofar [tcl::string::cat $linebuild $rawline] #ansi colours can stop info complete from working (contain square brackets) - if {![tcl::info::complete [punk::ansi::ansistrip $recordsofar]]} { + #review - when exactly are ansi codes allowed/expected in argspecs. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { #append linebuild [string trimleft $rawline] \n if {$in_record} { if {[tcl::string::length $lastindent]} { @@ -602,7 +646,7 @@ tcl::namespace::eval punk::args { } } } - -default - -solo - -range - -choices - -choiceprefix - -choicelabels - -choiceprefix - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE { + -default - -solo - -range - -choices - -choiceprefix - -choicelabels - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE { #review -solo 1 vs -type none ? tcl::dict::set spec_merged $spec $specval } @@ -711,8 +755,8 @@ tcl::namespace::eval punk::args { if {![catch {package require textblock}]} { if {[catch { append errmsg \n - set procname [punk::lib::dict_getdef $spec_dict proc_info -name ""] - set prochelp [punk::lib::dict_getdef $spec_dict proc_info -help ""] + set procname [::punk::args::Dict_getdef $spec_dict proc_info -name ""] + set prochelp [::punk::args::Dict_getdef $spec_dict proc_info -help ""] #set t [textblock::class::table new [a+ web-yellow]Usage[a]] set t [textblock::class::table new [a+ brightyellow]Usage[a]] @@ -787,7 +831,7 @@ tcl::namespace::eval punk::args { } else { set default "" } - set help [punk::lib::dict_getdef $arginfo -help ""] + set help [::punk::args::Dict_getdef $arginfo -help ""] if {[dict exists $arginfo -choices]} { if {$help ne ""} {append help \n} if {[dict get $arginfo -nocase]} { @@ -801,7 +845,7 @@ tcl::namespace::eval punk::args { set prefixmsg "" } append help "Choices$prefixmsg$casemsg" - if {[catch {package require punk::trie}]} { + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { append help "\n " [join [dict get $arginfo -choices] "\n "] } else { if {[catch { @@ -825,7 +869,7 @@ tcl::namespace::eval punk::args { } } } - if {[punk::lib::dict_getdef $arginfo -multiple 0]} { + if {[::punk::args::Dict_getdef $arginfo -multiple 0]} { set multiple $greencheck } else { set multiple "" @@ -842,7 +886,7 @@ tcl::namespace::eval punk::args { } else { set default "" } - set help [punk::lib::dict_getdef $arginfo -help ""] + set help [::punk::args::Dict_getdef $arginfo -help ""] if {[dict exists $arginfo -choices]} { if {$help ne ""} {append help \n} if {[dict get $arginfo -nocase]} { @@ -856,7 +900,7 @@ tcl::namespace::eval punk::args { set prefixmsg "" } append help "Choices$prefixmsg$casemsg" - if {[catch {package require punk::trie}]} { + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { append help "\n " [join [dict get $arginfo -choices] "\n "] } else { if {[catch { @@ -880,7 +924,7 @@ tcl::namespace::eval punk::args { } } } - if {[punk::lib::dict_getdef $arginfo -multiple 0]} { + if {[punk::args::Dict_getdef $arginfo -multiple 0]} { set multiple $greencheck } else { set multiple "" @@ -1261,10 +1305,10 @@ tcl::namespace::eval punk::args { # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" #} #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punk::lib::ldiff $opt_required $flagsreceived]]]} { + if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present in full-length form" $argspecs } - if {[llength [set missing [punk::lib::ldiff $val_required $valnames_received]]]} { + if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs } @@ -1396,14 +1440,25 @@ tcl::namespace::eval punk::args { package require ansi } int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive if {[tcl::dict::exists $thisarg -range]} { lassign [tcl::dict::get $thisarg -range] low high foreach e $vlist e_check $vlist_check { if {![tcl::string::is integer -strict $e_check]} { arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs $argname } - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer between $low and $high. Received: '$e'" $argspecs $argname + if {$low eq ""} { + if {$e_check < $low} { + arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs $argname + } + } elseif {$high eq ""} { + if {$e_check > $high} { + arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs $argname + } + } else { + if {$e_check < $low || $e_check > $high} { + arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs $argname + } } } } else { @@ -1426,6 +1481,7 @@ tcl::namespace::eval punk::args { switch -- $checkopt { -range { #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high lassign $checkval low high if {$e_check < $low || $e_check > $high} { arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs $argname @@ -1493,7 +1549,8 @@ tcl::namespace::eval punk::args { existingfile - existingdirectory { foreach e $vlist e_check $vlist_check { - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*?<>\;]} $e_check])} { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { #what about special file names e.g on windows NUL ? arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs $argname } diff --git a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm b/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm index 4cc3f00c..7cf3c602 100644 --- a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm +++ b/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm @@ -505,11 +505,13 @@ namespace eval punk::cap::handlers::templates { set subpathlist [split $tailats +] if {[dict exists $refinfo sourceinfo projectbase]} { #some template pathtypes refer to the projectroot from the template - not the cwd - set projectroot [dict get $refinfo sourceinfo projectbase] + set ref_projectroot [dict get $refinfo sourceinfo projectbase] + } else { + set ref_projectroot $projectroot } - if {$projectroot ne ""} { - set layoutroot [file join $projectroot src/project_layouts] + if {$ref_projectroot ne ""} { + set layoutroot [file join $ref_projectroot src/project_layouts] set layoutfolder [file join $layoutroot {*}$subpathlist] if {[file isdirectory $layoutfolder]} { #todo - check if layoutname already in layoutdict append .ref path to list of refs that linked to this layout? diff --git a/src/modules/punk/mix/base-0.1.tm b/src/modules/punk/mix/base-0.1.tm index dfdc71f9..d2d40bba 100644 --- a/src/modules/punk/mix/base-0.1.tm +++ b/src/modules/punk/mix/base-0.1.tm @@ -468,16 +468,15 @@ namespace eval punk::mix::base { #adler32 via file-slurp proc cksum_adler32_file {filename} { - package require zlib; #should be builtin anyway + #2024 - zlib should be builtin - otherwise fallback to trf + zlibtcl? set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] #set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names zlib adler32 $data } #zlib crc via file-slurp proc cksum_crc_file {filename} { - package require zlib set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] - zlib crc $data + zlib crc32 $data } proc cksum_md5_data {data} { diff --git a/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm b/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm index ba2663b0..718d358c 100644 --- a/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm @@ -22,7 +22,8 @@ package require punk::args #sort of a circular dependency when commandset loaded by punk::mix::cli - that's ok, but this could theoretically be loaded by another cli and with another base package require punk::mix package require punk::mix::base - +package require punk::lib +package require textblock # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -41,8 +42,10 @@ namespace eval punk::mix::commandset::layout { return [join $allfiles \n] } proc templatefiles {layout} { - set templatefiles [lib::layout_scan_for_template_files $layout] - return [join $templatefiles \n] + set templatefiles_and_tags [lib::layout_scan_for_template_files $layout] + set flatlist [punk::lib::lmapflat v $templatefiles_and_tags {lrange $v 0 end}] + #return [join $templatefiles \n] + textblock::list_as_table -header {"File with tags found" "Tags"} -columns 2 $flatlist } proc templatefiles.relative {layout} { @@ -56,12 +59,14 @@ namespace eval punk::mix::commandset::layout { set stripprefix [file normalize $layoutfolder] - set templatefiles [lib::layout_scan_for_template_files $layout] - set tails [list] - foreach templatefullpath $templatefiles { - lappend tails [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] + set templatefiles_and_tags [lib::layout_scan_for_template_files $layout] + set flatlist [list] + foreach entry $templatefiles_and_tags { + lassign $entry templatefullpath tags + lappend flatlist [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] $tags } - return [join $tails \n] + #return [join $tails \n] + textblock::list_as_table -header {"File with tags found" "Tags"} -columns 2 $flatlist } #layout collection functions - to be imported with punk::overlay::import_commandset separately @@ -110,28 +115,16 @@ namespace eval punk::mix::commandset::layout { } set title(path) "Path" - set widest(path) [tcl::mathfunc::max {*}[lmap v [concat [list $title(path)] $paths] {punk::strlen $v}]] - set col(path) [string repeat " " $widest(path)] set title(pathtype) "[a+ green]Path Type[a]" - set widest(pathtype) [tcl::mathfunc::max {*}[lmap v [concat [list $title(pathtype)] $pathtypes] {punk::strlen $v}]] - set col(pathtype) [string repeat " " $widest(pathtype)] set title(name) "Layout Name" - set widest(name) [tcl::mathfunc::max {*}[lmap v [concat [list $title(name)] $names] {punk::strlen $v}]] - set col(name) [string repeat " " $widest(name)] - - set vsep " | " - set vsep_w [string length $vsep] ;#unicode? - set tablewidth [expr {$widest(name) + $vsep_w + $widest(pathtype) + $vsep_w + $widest(path)}] - set table "" - append table [string repeat - $tablewidth] \n - append table "[textblock::join -- [overtype::left $col(name) $title(name)] $vsep [overtype::left $col(pathtype) $title(pathtype)] $vsep [overtype::left $col(path) $title(path)]]" \n - append table [string repeat - $tablewidth] \n + set data [list] foreach n $names pt $pathtypes p $paths { - append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n + lappend data $n $pt $p } + set table [textblock::list_as_table -columns 3 -header [list $title(name) $title(pathtype) $title(path)] $data] return $table } @@ -156,29 +149,16 @@ namespace eval punk::mix::commandset::layout { lappend pathtypes [dict get $tinfo sourceinfo pathtype] } - set title(path) "Path" - set widest(path) [tcl::mathfunc::max {*}[lmap v [concat [list $title(path)] $paths] {punk::strlen $v}]] - set col(path) [string repeat " " $widest(path)] - - set title(pathtype) "[a+ green]Path Type[a]" - set widest(pathtype) [tcl::mathfunc::max {*}[lmap v [concat [list $title(pathtype)] $pathtypes] {punk::strlen $v}]] - set col(pathtype) [string repeat " " $widest(pathtype)] - set title(name) "Layout Name" - set widest(name) [tcl::mathfunc::max {*}[lmap v [concat [list $title(name)] $names] {punk::strlen $v}]] - set col(name) [string repeat " " $widest(name)] - - set vsep " | " - set vsep_w [string length $vsep] ;#unicode? - set tablewidth [expr {$widest(name) + $vsep_w + $widest(pathtype) + $vsep_w + $widest(path)}] - set table "" - append table [string repeat - $tablewidth] \n - append table "[textblock::join -- [overtype::left $col(name) $title(name)] $vsep [overtype::left $col(pathtype) $title(pathtype)] $vsep [overtype::left $col(path) $title(path)]]" \n - append table [string repeat - $tablewidth] \n + set title(pathtype) "[a+ green]Path Type[a]" + set title(path) "Path" + set data [list] foreach n $names pt $pathtypes p $paths { - append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n + #append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n + lappend data $n $pt $p } + set table [textblock::list_as_table -columns 3 -header [list $title(name) $title(pathtype) $title(path)] $data] return $table } @@ -243,7 +223,7 @@ namespace eval punk::mix::commandset::layout { #todo - get standard tags from somewhere set tagnames [list project] foreach tn $tagnames { - lappend tags [string cat % $tn %] + lappend tags [string cat % $tn %] ;#make sure actual tag literal doesn't appear in this source file } } set file_list [list] @@ -252,11 +232,15 @@ namespace eval punk::mix::commandset::layout { fconfigure $fd -translation binary set data [read $fd] close $fd - foreach tag $tags { + set found_tags [list] + foreach tag $tags tn $tagnames { if {[string match "*$tag*" $data]} { - lappend file_list $path + lappend found_tags $tn } } + if {[llength $found_tags]} { + lappend file_list [list $path $found_tags] + } } return $file_list diff --git a/src/modules/punk/mix/templates/modules/modulename_buildversion.txt b/src/modules/punk/mix/templates/modules/modulename_buildversion.txt index 53815fbd..98029ad8 100644 --- a/src/modules/punk/mix/templates/modules/modulename_buildversion.txt +++ b/src/modules/punk/mix/templates/modules/modulename_buildversion.txt @@ -1,3 +1,3 @@ %Major.Minor.Level% -#First line must be a semantic version number +#First line must be a tcl package version number #all other lines are ignored. diff --git a/src/modules/punk/repl-0.1.tm b/src/modules/punk/repl-0.1.tm index fe55bfd6..a425946f 100644 --- a/src/modules/punk/repl-0.1.tm +++ b/src/modules/punk/repl-0.1.tm @@ -2534,7 +2534,8 @@ namespace eval repl { } #in case -callback_interp wasn't explicitly defined - we make a guess based on how init was called as to whether this is being launched from a 'code' or root ("") interp. if {[catch {info level -1} caller]} { - puts "repl::init from: global" + #todo logger + #puts "repl::init from: global" set default_callback_interp "" } else { #puts "repl::init from: $caller" @@ -2909,7 +2910,7 @@ namespace eval repl { set ::auto_path %autopath% tcl::tm::remove {*}[tcl::tm::list] tcl::tm::add {*}[lreverse %tmlist%] - puts "code interp chan names-->[chan names]" + #puts "code interp chan names-->[chan names]" namespace eval ::codeinterp { variable errstack {} variable outstack {} diff --git a/src/modules/punk/zip-999999.0a1.0.tm b/src/modules/punk/zip-999999.0a1.0.tm index f213cb6b..fa9859c5 100644 --- a/src/modules/punk/zip-999999.0a1.0.tm +++ b/src/modules/punk/zip-999999.0a1.0.tm @@ -244,26 +244,186 @@ tcl::namespace::eval punk::zip { if {!$excluded} {lappend result $file} } foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { - set subdir [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] - if {[llength $subdir]>0} { - set result [concat $result $dir $subdir] + set subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] + if {[llength $subdir_entries]>0} { + #NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" + #This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash + #Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. + set result [list {*}$result "$dir/" {*}$subdir_entries] } } return $result } - # Mkzipfile -- + #if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) + #Otherwise extract an internal preamble. + #if neither - + #review - reconsider auto-determination of internal vs external preamble + proc extract_preamble {infile outfile_preamble {outfile_zip ""}} { + set inzip [open $infile r] + fconfigure $inzip -encoding iso8859-1 -translation binary + if {[file exists $outfile_preamble]} { + error "outfile_preamble $outfile_preamble already exists - please remove first" + } + if {$outfile_zip ne ""} { + if {[file exists $outfile_zip] && [file size $outfile_zip]} { + error "outfile_zip $outfile_zip already exists - please remove first" + } + } + chan seek $inzip 0 end + set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent + chan seek $inzip 0 start + #only scan last 64k - cover max signature size?? review + if {$insize < 65559} { + set tailsearch_start 0 + } else { + set tailsearch_start [expr {$insize - 65559}] + } + chan seek $inzip $tailsearch_start start + set scan [read $inzip] + #EOCD - End Of Central Directory record + set start_of_end [string last "\x50\x4b\x05\x06" $scan] + puts stdout "==>start_of_end: $start_of_end" + + if {$start_of_end == -1} { + #no zip eocdr - consider entire file to be the zip preamble + set baseoffset $insize + } else { + set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] + chan seek $inzip $filerelative_eocd_posn + set cdir_record_plus [read $inzip] ;#can have trailing data + binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + #rule out a false positive from within a nonzip (e.g plain exe) + #There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. + #It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway + #we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros + #todo - just search for Pk\5\6\0\0\0\0 in the first place? //review + if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { + #review - should keep searching? + #for now we assume not a zip + set baseoffset $insize + } else { + #use the central dir size to jump back tko start of central dir + #determine if diroffset is file or archive relative + + set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] + puts stdout "---> [read $inzip 4]" + if {$filerelative_cdir_start > $eocd(diroffset)} { + #'external preamble' easy case + # - ie 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier + #though we are assuming zip offsets are not corrupted + set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] + } else { + #'internal preamble' hard case + # - either no preamble - or offsets have been adjusted to be file relative. + #we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers + #we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? + #or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete + + #step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) + #we can't assume they're ordered in any particular way - so we in theory have to look at them all. + set baseoffset "unknown" + chan seek $inzip $filerelative_cdir_start start + #binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + # eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + #load the whole central dir into cdir + + #todo! loop through all cdr file headers - find highest offset? + #tclZipfs.c just looks at first file header in Central Directory + #looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW + + set cdirdata [read $inzip $eocd(dirsize)] + binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ + cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ + cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) + + #since we're in this branch - we assume cdir(relativeoffset) is from the start of the file + chan seek $inzip $cdir(relativeoffset) + #let's at least check that we landed on a local file header.. + set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field + binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ + lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) + #dec2hex 67324752 = 4034B50 = PK\3\4 + puts stdout "1st local file header sig: $lfh(signature)" + if {$lfh(signature) == 67324752} { + #looks like a local file header + #use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) + set baseoffset $cdir(relativeoffset) + } + } + puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" + } + } + puts stdout "baseoffset: $baseoffset" + #expect CDFH PK\1\2 + #above the CD - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) + #above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script + + if {![string is integer -strict $baseoffset]} { + error "unable to determine zip baseoffset of file $infile" + } + + if {$baseoffset < $insize} { + set pout [open $outfile_preamble w] + fconfigure $pout -encoding iso8859-1 -translation binary + chan seek $inzip 0 start + chan copy $inzip $pout -size $baseoffset + close $pout + if {$outfile_zip ne ""} { + #todo - if it was internal preamble - need to adjust offsets to fix the split off zipfile + set zout [open $outfile_zip w] + fconfigure $zout -encoding iso8859-1 -translation binary + chan copy $inzip $zout + close $zout + } + close $inzip + } else { + #no valid (from our perspective) eocdr found - baseoffset has been set to insize + close $inzip + file copy $infile $outfile_preamble + if {$outfile_zip ne ""} { + #touch equiv? + set fd [open $outfile_zip w] + close $fd + } + } + } + + + + # Addentry - was Mkzipfile -- # # FIX ME: should handle the current offset for non-seekable channels # - proc Mkzipfile {zipchan base path {comment ""}} { + proc Addentry {args} { #*** !doctools - #[call [fun Mkzipfile] [arg zipchan] [arg base] [arg path] [arg ?comment?]] + #[call [fun Addentry] [arg zipchan] [arg base] [arg path] [arg ?comment?]] #[para] Add a single file to a zip archive #[para] The zipchan channel should already be open and binary. #[para] You can provide a -comment for the file. #[para] The return value is the central directory record that will need to be used when finalizing the zip archive. + set argd [punk::args::get_dict { + *proc -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' + return a central directory file record" + *opts + -comment -default "" -help "An optional comment specific to the added file" + *values -min 3 -max 4 + zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" + base -help "base path for entries" + path -type file -help "path of file to add" + zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe + Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" + } $args] + + set zipchan [dict get $argd values zipchan] + set base [dict get $argd values base] + set path [dict get $argd values path] + set zipdataoffset [dict get $argd values zipdataoffset] + + set comment [dict get $argd opts -comment] + set fullpath [file join $base $path] set mtime [Timet_to_dos [file mtime $fullpath]] set utfpath [encoding convertto utf-8 $path] @@ -296,7 +456,7 @@ tcl::namespace::eval punk::zip { } - set offset [tell $zipchan] + set channeloffset [tell $zipchan] ;#position in the channel - this may include prefixing exe/zip set local [binary format a4sssiiiiss PK\03\04 \ $version $flags $method $mtime $crc $csize $size \ [string length $utfpath] [string length $extra]] @@ -346,7 +506,7 @@ tcl::namespace::eval punk::zip { set local [binary format a4sssiiii PK\03\04 \ $version $flags $method $mtime $crc $csize $size] set current [tell $zipchan] - seek $zipchan $offset + seek $zipchan $channeloffset puts -nonewline $zipchan $local seek $zipchan $current } else { @@ -363,38 +523,53 @@ tcl::namespace::eval punk::zip { set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ $version $flags $method $mtime $crc $csize $size \ [string length $utfpath] [string length $extra]\ - [string length $utfcomment] 0 $attr $attrex $offset] + [string length $utfcomment] 0 $attr $attrex [expr {$channeloffset - $zipdataoffset}]] ;#zipdataoffset may be zero - either because it's a pure zip, or file-based offsets desired. append hdr $utfpath $extra $utfcomment return $hdr } + + #### REVIEW!!! + #JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') + # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) + #### + # zip::mkzip -- # # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt # proc mkzip {args} { + #todo - doctools - [arg ?globs...?] syntax? + #*** !doctools - #[call [fun mkzip] [arg ?options?] [arg filename]] + #[call [fun mkzip] [arg ?options?] [arg filename] ] #[para] Create a zip archive in 'filename' #[para] If a file already exists, an error will be raised. set argd [punk::args::get_dict { *proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" *opts + -offsettype -default "archive" -choices {archive file} -help "zip offsets stored relative to start of entire file or relative to start of zip-archive + Only relevant if the created file has a script/runtime prefix. + " -return -default "pretty" -choices {pretty list none} -help "mkzip can return a list of the files and folders added to the archive the option -return pretty is the default and uses the punk::lib pdict/plist system to return a formatted list for the terminal " - -zipkit -default 0 -type none -help "" + -zipkit -default 0 -type none -help "whether to add mounting script + mutually exclusive with -runtime option + currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs + " -runtime -default "" -help "specify a prefix file - e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip will create a self-extracting zip archive from the subdir/ folder. + Expects runtime with no existing vfs attached (review) " -comment -default "" -help "An optional comment for the archive" -directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" -base -default "" -help "The new zip archive will be rooted in this directory if provided - it must be a parent of -directory" + it must be a parent of -directory or the same path as -directory" -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} *values -min 1 -max -1 - filename -default "" -help "name of zipfile to create" + filename -type file -default "" -help "name of zipfile to create" globs -default {*} -multiple 1 -help "list of glob patterns to match. Only directories with matching files will be included in the archive" } $args] @@ -428,7 +603,7 @@ tcl::namespace::eval punk::zip { if {$opts(-base) ne ""} { #-base and -directory have been normalized already if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { - error "punk::zip::mkzip -base $opts(-base) must be above -directory $opts(-directory)" + error "punk::zip::mkzip -base $opts(-base) must be above or the same as -directory $opts(-directory)" } set base $opts(-base) set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] @@ -522,10 +697,13 @@ tcl::namespace::eval punk::zip { set zf [open $filename wb] if {$opts(-runtime) ne ""} { + #todo - strip any existing vfs - option to merge contents.. only if zip attached? set rt [open $opts(-runtime) rb] fcopy $rt $zf close $rt } elseif {$opts(-zipkit)} { + #TODO - update to zipfs ? + #see modpod set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" append zkd "package require vfs::zip\n" append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" @@ -535,6 +713,14 @@ tcl::namespace::eval punk::zip { append zkd \x1A puts -nonewline $zf $zkd } + + #todo - subtract this from the endrec offset + if {$opts(-offsettype) eq "archive"} { + set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024 + } else { + set dataStartOffset 0 ;#offsets relative to file - the zipfs mkzip way :/ + } + set count 0 set cd "" @@ -542,7 +728,7 @@ tcl::namespace::eval punk::zip { foreach path $paths { #puts $path lappend members $path - append cd [Mkzipfile $zf $base $path] ;#path already includes relpath + append cd [Addentry $zf $base $path $dataStartOffset] ;#path already includes relpath incr count } set cdoffset [tell $zf] diff --git a/src/modules/punk/zip-buildversion.txt b/src/modules/punk/zip-buildversion.txt index f47d01c8..781c895b 100644 --- a/src/modules/punk/zip-buildversion.txt +++ b/src/modules/punk/zip-buildversion.txt @@ -1,3 +1,3 @@ -0.1.0 +0.1.1 #First line must be a semantic version number #all other lines are ignored. diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 40e60f9c..572ce27e 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -4040,7 +4040,8 @@ tcl::namespace::eval textblock { -show_hseps -default "" -type boolean -help "Show horizontal table separators (default 0 if no existing -table supplied)" -table -default "" -type string -help "existing table object to use" - -headers -default "" -help "list of header values. Must match number of columns" + -colheaders -default "" -type list -help "list of lists. list of column header values. Outer list must match number of columns" + -header -default "" -type list -multiple 1 -help "Headers left to right" -show_header -default "" -help "Whether to show a header row. Leave as empty string for unspecified/automatic, in which case it will display only if -headers list was supplied." @@ -4104,9 +4105,41 @@ tcl::namespace::eval textblock { } } else { set is_new_table 1 - set headers {} - if {[tcl::dict::get $opts -headers] ne ""} { - set headers [dict get $opts -headers] + set colheaders {} + if {[tcl::dict::get $opts -colheaders] ne ""} { + set colheaders [dict get $opts -colheaders] + } else { + set colheaders [list] + } + set r 0 + foreach ch $colheaders { + set rows [llength $ch] + if {$r < $rows} { + set r $rows + } + } + if {[llength [tcl::dict::get $opts -header]]} { + foreach hrow [tcl::dict::get $opts -header] { + set c 0 + foreach cell $hrow { + if {[llength $colheaders] < $c+1} { + lappend colheaders [lrepeat $r {}] + } + set colinfo [lindex $colheaders $c] + if {$r > [llength $colinfo]} { + set diff [expr {$r - [llength $colinfo]}] + lappend colinfo {*}[lrepeat $diff {}] + } + lappend colinfo $cell + lset colheaders $c $colinfo + incr c + } + incr r + } + } + + + if {[llength $colheaders] > 0} { if {[tcl::dict::get $opts -show_header] eq ""} { set show_header 1 } else { @@ -4122,13 +4155,13 @@ tcl::namespace::eval textblock { if {[tcl::string::is integer -strict $opt_columns]} { set cols $opt_columns - if {[llength $headers] && $cols != [llength $headers]} { - error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $headers])" + if {[llength $colheaders] && $cols != [llength $colheaders]} { + error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $colheaders])" } } else { #review - if {[llength $headers]} { - set cols [llength $headers] + if {[llength $colheaders]} { + set cols [llength $colheaders] } else { set cols 2 ;#seems a reasonable default } @@ -4158,9 +4191,9 @@ tcl::namespace::eval textblock { -show_vseps [tcl::dict::get $opts -show_vseps]\ -show_hseps [tcl::dict::get $opts -show_hseps]\ ] - if {[llength $headers]} { + if {[llength $colheaders]} { for {set c 0} {$c < $cols} {incr c} { - $t add_column -headers [lindex $headers $c] + $t add_column -headers [lindex $colheaders $c] } } else { for {set c 0} {$c < $cols} {incr c} { @@ -5261,6 +5294,7 @@ tcl::namespace::eval textblock { if {[tcl::dict::exists $framedef_cache $cache_key]} { return [tcl::dict::get $framedef_cache $cache_key] } + set argopts [lrange $args 0 end-1] set f [lindex $args end] @@ -5292,10 +5326,10 @@ tcl::namespace::eval textblock { -boxonly -default 0 -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 -help "name from the predefined frametypes: - or an adhoc " + frametype -choices "" -choiceprefix 0 -help "name from the predefined frametypes + or an adhoc dictionary." }] - append spec \n "frametype -help \"A predefined \"" + #append spec \n "frametype -help \"A predefined \"" punk::args::get_dict $spec $args return } diff --git a/src/modules/textblock-buildversion.txt b/src/modules/textblock-buildversion.txt index 781c895b..32568297 100644 --- a/src/modules/textblock-buildversion.txt +++ b/src/modules/textblock-buildversion.txt @@ -1,3 +1,3 @@ -0.1.1 +0.1.2 #First line must be a semantic version number #all other lines are ignored. diff --git a/src/modules/zipper-buildversion.txt b/src/modules/zipper-buildversion.txt new file mode 100644 index 00000000..a49e6497 --- /dev/null +++ b/src/modules/zipper-buildversion.txt @@ -0,0 +1,3 @@ +0.12 +#First line must be a tm version number +#all other lines are ignored. diff --git a/src/vendormodules/fauxlink-0.1.1.tm b/src/vendormodules/fauxlink-0.1.1.tm new file mode 100644 index 00000000..7aff6ec0 --- /dev/null +++ b/src/vendormodules/fauxlink-0.1.1.tm @@ -0,0 +1,567 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application fauxlink 0.1.1 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin fauxlink_module_fauxlink 0 0.1.1] +#[copyright "2024"] +#[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}] +#[moddesc {fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] +#[require fauxlink] +#[keywords symlink faux fake shortcut toml] +#[description] +#[para] A cross platform shortcut/symlink alternative. +#[para] Unapologetically ugly - but practical in certain circumstances. +#[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as +#[para] archiving and packaging systems. +#[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable. +#[para] format of name #.fxlnk +#[para] where can be empty - then the effective nominal name is the tail of the +#[para] The + symbol substitutes for forward-slashes. +#[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) +#[para] We deliberately treat higher % sequences literally. +#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [heart]) can remain literal for linking to urls. +#[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 +#[para] e.g a link to a file file#A.txt in parent dir could be: +#[para] file%23A.txt#..+file%23A.txt.fxlnk +#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fxlnk +#[para] The can be unrelated to the actual target +#[para] e.g datafile.dat#..+file%23A.txt.fxlnk +#[para] This system has no filesystem support - and must be completely application driven. +#[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform. +#[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined +#[para] Extensions to behaviour should be added in the file as text data in Toml format, +#[para] with custom data being under a single application-chosen table name +#[para] The toplevel Toml table [fauxlink] is reserved for core extensions to this system. +#[para] Aside from the 2 used for delimiting (+ #) +#[para] certain characters which might normally be allowed in filesystems are required to be encoded +#[para] e.g space and tab are required to be %20 %09 +#[para] Others that require encoding are: * ? \ / | : ; " < > +#[para] The nul character in raw form, when detected, is always mapped away to the empty string - as very few filesystems support it. +#[para] Control characters and other punctuation is optional to encode. +#[para] Generally utf-8 should be used where possible and unicode characters can often be left unencoded on modern systems. +#[para] Where encoding of unicode is desired in the nominalname,encodedtarget,tag or comment portions it can be specified as %UXXXXXXXX +#[para] There must be between 1 and 8 X digits following the %U. Interpretation of chars following %U stops at the first non-hex character. +#[para] This means %Utest would not get any translation as there were no hex digits so it would come out as %Utest +# +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded +# ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it. +#Using fauxlink - a link would be: +# "my-program-files#++server+c+Program%20Files.fxlnk" +#If we needed the old-style literal %20 it would become +# "my-program-files#++server+c+Program%2520Files.fxlnk" +# +# The file:// scheme on windows supposedly *does* decode %xx (for use in a browser) +# e.g +# pfiles#file%3a++++localhost+c+Program%2520files +# The browser will work with literal spaces too though - so it could just as well be: +# pfiles#file%3a++++localhost+c+Program%20files +#windows may default to using explorer.exe instead of a browser for file:// urls though +#and explorer doesn't want the literal %20. It probably depends what API the file:// url is to be passed to? +#in a .url shortcut either literal space or %20 will work ie %xx values are decoded + + + +#*** !doctools +#[section Overview] +#[para] overview of fauxlink +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by fauxlink +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval fauxlink::class { + #*** !doctools + #[subsection {Namespace fauxlink::class}] + #[para] class definitions + if {[info commands [namespace current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval fauxlink { + namespace export {[a-z]*}; # Convention: export all lowercase + + #todo - enforce utf-8 + + #literal unicode chars supported by modern filesystems - leave as is - REVIEW + + + variable encode_map + variable decode_map + #most filesystems don't allow NULL - map to empty string + + #Make sure % is not in encode_map + set encode_map [dict create\ + \x00 ""\ + { } %20\ + \t %09\ + + %2B\ + # %23\ + * %2A\ + ? %3F\ + \\ %5C\ + / %2F\ + | %7C\ + : %3A\ + {;} %3B\ + {"} %22\ + < %3C\ + > %3E\ + ] + #above have some overlap with ctrl codes below. + #no big deal as it's a dict + + #must_encode + # + # * ? \ / | : ; " < > \t + # also NUL to empty string + + # also ctrl chars 01 to 1F (1..31) + for {set i 1} {$i < 32} {incr i} { + set ch [format %c $i] + set enc "%[format %02X $i]" + set enc_lower [string tolower $enc] + dict set encode_map $ch $enc + dict set decode_map $enc $ch + dict set decode_map $enc_lower $ch + } + + variable must_encode + set must_encode [dict keys $encode_map] + + + #if they are in + + #decode map doesn't include + # %00 (nul) + # %2F "/" + # %2f "/" + # %7f (del) + #we exlude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. + # + set decode_map [dict merge $decode_map [dict create\ + %09 \t\ + %20 { }\ + %21 "!"\ + %22 {"}\ + %23 "#"\ + %24 "$"\ + %25 "%"\ + %26 "&"\ + %27 "'"\ + %28 "("\ + %29 ")"\ + %2A "*"\ + %2a "*"\ + %2B "+"\ + %2b "+"\ + %2C ","\ + %2c ","\ + %2D "-"\ + %2d "-"\ + %2E "."\ + %2e "."\ + %3A ":"\ + %3a ":"\ + %3B {;}\ + %3b {;}\ + %3D "="\ + %3C "<"\ + %3c "<"\ + %3d "="\ + %3E ">"\ + %3e ">"\ + %3F "?"\ + %3f "?"\ + %40 "@"\ + %5B "\["\ + %5b "\["\ + %5C "\\"\ + %5c "\\"\ + %5D "\]"\ + %5d "\]"\ + %5E "^"\ + %5e "^"\ + %60 "`"\ + %7B "{"\ + %7b "{"\ + %7C "|"\ + %7c "|"\ + %7D "}"\ + %7d "}"\ + %7E "~"\ + %7e "~"\ + ]] + #Don't go above 7f + #if we want to specify p + + + #*** !doctools + #[subsection {Namespace fauxlink}] + #[para] Core API functions for fauxlink + #[list_begin definitions] + proc Segment_mustencode_check {str} { + variable decode_map + variable encode_map ;#must_encode + set idx 0 + set err "" + foreach ch [split $str ""] { + if {[dict exists $encode_map $ch]} { + set enc [dict get $encode_map $ch] + if {[dict exists $decode_map $enc]} { + append err " char $idx should be encoded as $enc" \n + } else { + append err " no %xx encoding available. Use %UXX if really required" \n + } + } + incr idx + } + return $err ;#empty string if ok + } + + proc resolve {link} { + variable decode_map + variable encode_map + variable must_encode + set ftail [file tail $link] + set extension_name [string range [file extension $ftail] 1 end] + if {$extension_name ni [list fxlnk fauxlink]} { + set is_fauxlink 0 + #we'll process anyway - but return the result wrapped + #This should allow deliberate erroring for the calling dict user if the extension difference is inadvertent + #(e.g blindly processing all files in a folder that is normally only .fxlnk files - but then something added that happens + # to have # characters in it) + #It also means if someone really wants to use the fauxlink semantics on a different file type + # - they can - but just have to access the results differently and take that (minor) risk. + #error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" + set err_extra "\nnonstandard extension '$extension_name' for fauxlink. Check that the call to fauxlink::resolve was deliberate" + } else { + set is_fauxlink 1 + set err_extra "" + } + set linkspec [file rootname $ftail] + # - any # or + within the target path or name should have been uri encoded as %23 and %2b + if {[tcl::string::first # $linkspec] < 0} { + set err "fauxlink::resolve '$link'. Link must contain a # (usually at start if name matches target)" + append err $err_extra + error $err + } + #The 1st 2 parts of split on # are name and target file/dir + #If there are only 3 parts the 3rd part is a comment and there are no 'tags' + #if there are 4 parts - the 3rd part is a tagset where each tag begins with @ + #and each subsequent part is a comment. Empty comments are stripped from the comments list + #A tagset can be empty - but if it's not empty it must contain at least one @ and must start with @ + #e.g name.txt#path#@tag1@tag2#test###.fxlnk + #has a name, a target, 2 tags and one comment + + #check namespec already has required chars encoded + set segments [split $linkspec #] + lassign $segments namespec targetspec + #puts stderr "-->namespec $namespec" + set nametest [tcl::string::map $encode_map $namespec] + #puts stderr "-->nametest $nametest" + #nothing should be changed - if there are unencoded chars that must be encoded it is an error + if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} { + set err "fauxlink::resolve '$link' invalid chars in name part (section prior to first #)" + append err [Segment_mustencode_check $namespec] + append err $err_extra + error $err + } + #see comments below regarding 2 rounds and ordering. + set name [decode_unicode_escapes $namespec] + set name [tcl::string::map $decode_map $name] + #puts stderr "-->name: $name" + + set targetsegment [split $targetspec +] + #check each + delimited part of targetspec already has required chars encoded + set pp 0 ;#pathpart index + set targetpath_parts [list] + foreach pathpart $targetsegment { + set targettest [tcl::string::map $encode_map $pathpart] + if {[tcl::string::length $targettest] ne [tcl::string::length $pathpart]} { + set err "fauxlink::resolve '$link' invalid chars in targetpath (section following first #)" + append err [Segment_mustencode_check $pathpart] + append err $err_extra + error $err + } + #2 rounds of substitution is possibly asking for trouble.. + #We allow anything in the resultant segments anyway (as %UXXXX... allows all) + #so it's not so much about what can be encoded, + # - but it makes it harder to reason about for users + # In particular - if we map %XX first it makes %25 -> % substitution tricky + # if the user requires a literal %UXXX - they can't do %25UXXX + # the double sub would make it %UXXX -> somechar anyway. + #we do unicode first - as a 2nd round of %XX substitutions is unlikely to interfere. + #There is still the opportunity to use things like %U00000025 followed by hex-chars + # and get some minor surprises, but using %U on ascii is unlikely to be done accidentally - REVIEW + set pathpart [decode_unicode_escapes $pathpart] + set pathpart [tcl::string::map $decode_map $pathpart] + lappend targetpath_parts $pathpart + + incr pp + } + set targetpath [join $targetpath_parts /] + if {$name eq ""} { + set name [lindex $targetpath_parts end] + } + #we do the same encoding checks on tags and comments to increase chances of portability + set tags [list] + set comments [list] + switch -- [llength $segments] { + 2 { + #no tags or comments + } + 3 { + #only 3 sections - last is comment - even if looks like tags + #to make the 3rd part a tagset, an extra # would be needed + set comments [list [lindex $segments 2]] + } + default { + set tagset [lindex $segments 2] + if {$tagset eq ""} { + #ok - no tags + } else { + if {[string first @ $tagset] != 0} { + set err "fauxlink::resolve '$link' invalid tagset in 3rd #-delimited segment" + append err \n " - must begin with @" + append err $err_extra + error $err + } else { + set tagset [string range $tagset 1 end] + set rawtags [split $tagset @] + set tags [list] + foreach t $rawtags { + if {$t eq ""} { + lappend tags "" + } else { + set tagtest [tcl::string::map $encode_map $t] + if {[tcl::string::length $tagtest] ne [tcl::string::length $t]} { + set err "fauxlink::resolve '$link' invalid chars in tag [llength $tags]" + append err [Segment_mustencode_check $t] + append err $err_extra + error $err + } + lappend tags [tcl::string::map $decode_map [decode_unicode_escapes $t]] + } + } + } + } + set rawcomments [lrange $segments 3 end] + #set comments [lsearch -all -inline -not $comments ""] + set comments [list] + foreach c $rawcomments { + if {$c eq ""} {continue} + set commenttest [tcl::string::map $encode_map $c] + if {[tcl::string::length $commenttest] ne [tcl::string::length $c]} { + set err "fauxlink::resolve '$link' invalid chars in comment [llength $comments]" + append err [Segment_mustencode_check $c] + append err $err_extra + error $err + } + lappend comments [tcl::string::map $decode_map [decode_unicode_escapes $c]] + } + } + } + + set data [dict create name $name targetpath $targetpath tags $tags comments $comments fauxlinkextension $extension_name] + if {$is_fauxlink} { + #standard .fxlnk or .fauxlink + return $data + } else { + #custom extension - or called in error on wrong type of file but happened to parse. + #see comments at top regarding is_fauxlink + #make sure no keys in common at top level. + return [dict create\ + linktype $extension_name\ + note "nonstandard extension returning nonstandard dict with result in data key"\ + data $data\ + ] + } + } + variable map + + #default exclusion of / (%U2f and equivs) + #this would allow obfuscation of intention - when we have + for that anyway + proc decode_unicode_escapes {str {exclusions {/ \n \r \x00}}} { + variable map + set ucstart [string first %U $str 0] + if {$ucstart < 0} { + return $str + } + set max 8 + set map [list] + set strend [expr {[string length $str]-1}] + while {$ucstart >= 0} { + set s $ucstart + set i [expr {$s +2}] ;#skip the %U + set hex "" + while {[tcl::string::length $hex] < 8 && $i <= $strend} { + set in [string index $str $i] + if {[tcl::string::is xdigit -strict $in]} { + append hex $in + } else { + break + } + incr i + } + if {$hex ne ""} { + incr i -1 + lappend map $s $i $hex + } + set ucstart [tcl::string::first %U $str $i] + } + set out "" + set lastidx -1 + set e 0 + foreach {s e hex} $map { + append out [string range $str $lastidx+1 $s-1] + set sub [format %c 0x$hex] + if {$sub in $exclusions} { + append out %U$hex ;#put it back + } else { + append out $sub + } + set lastidx $e + } + if {$e < [tcl::string::length $str]-1} { + append out [string range $str $e+1 end] + } + return $out + } + proc link_as {name target} { + + } + + #proc sample1 {p1 args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [opt {?option value...?}]] + # #[para]Description of sample1 + # return "ok" + #} + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace fauxlink ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval fauxlink::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace fauxlink::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace fauxlink::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval fauxlink::system { + #*** !doctools + #[subsection {Namespace fauxlink::system}] + #[para] Internal functions that are not part of the API + + + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide fauxlink [namespace eval fauxlink { + variable pkg fauxlink + variable version + set version 0.1.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vendormodules/modpod-0.1.2.tm b/src/vendormodules/modpod-0.1.2.tm new file mode 100644 index 00000000..166bd423 --- /dev/null +++ b/src/vendormodules/modpod-0.1.2.tm @@ -0,0 +1,699 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application modpod 0.1.2 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin modpod_module_modpod 0 0.1.2] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require modpod] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of modpod +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by modpod +#[list_begin itemized] + +package require Tcl 8.6- +package require struct::set ;#review +package require punk::lib +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval modpod::class { + #*** !doctools + #[subsection {Namespace modpod::class}] + #[para] class definitions + if {[info commands [namespace current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval modpod { + namespace export {[a-z]*}; # Convention: export all lowercase + + variable connected + if {![info exists connected(to)]} { + set connected(to) list + } + variable modpodscript + set modpodscript [info script] + if {[string tolower [file extension $modpodscript]] eq ".tcl"} { + set connected(self) [file dirname $modpodscript] + } else { + #expecting a .tm + set connected(self) $modpodscript + } + variable loadables [info sharedlibextension] + variable sourceables {.tcl .tk} ;# .tm ? + + #*** !doctools + #[subsection {Namespace modpod}] + #[para] Core API functions for modpod + #[list_begin definitions] + + + + #proc sample1 {p1 args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [opt {?option value...?}]] + # #[para]Description of sample1 + # return "ok" + #} + + #old tar connect mechanism - review - not needed? + proc connect {args} { + puts stderr "modpod::connect--->>$args" + set argd [punk::args::get_dict { + -type -default "" + *values -min 1 -max 1 + path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" + } $args] + catch { + punk::lib::showdict $argd ;#heavy dependencies + } + set opt_path [dict get $argd values path] + variable connected + set original_connectpath $opt_path + set modpodpath [modpod::system::normalize $opt_path] ;# + + if {$modpodpath in $connected(to)} { + return [dict create ok ALREADY_CONNECTED] + } + lappend connected(to) $modpodpath + + set connected(connectpath,$opt_path) $original_connectpath + set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] + + set connected(location,$modpodpath) [file dirname $modpodpath] + set connected(startdata,$modpodpath) -1 + set connected(type,$modpodpath) [dict get $argd opts -type] + set connected(fh,$modpodpath) "" + + if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { + set connected(type,$modpodpath) "unwrapped" + lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] + + } else { + #connect to .tm but may still be unwrapped version available + lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + set this_pkg_tm_folder [file dirname $modpodpath] + if {$connected(type,$modpodpath) ne "unwrapped"} { + #Not directly connected to unwrapped version - but may still be redirected there + set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] + if {[file exists $unwrappedFolder]} { + #folder with exact version-match must exist for redirect to 'unwrapped' + set con(type,$modpodpath) "modpod-redirecting" + } + } + + } + set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" + set connected(tmfile,$modpodpath) + set tail_segments [list] + set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] + set lcase_modulepaths [string tolower [tcl::tm::list]] + foreach lc_mpath $lcase_modulepaths { + set mpath_segments [file split $lc_mpath] + if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { + set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] + break + } + } + if {[llength $tail_segments]} { + set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require + } else { + set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] + } + + switch -exact -- $connected(type,$modpodpath) { + "modpod-redirecting" { + #redirect to the unwrapped version + set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] + + } + "unwrapped" { + if {[info commands ::thread::id] ne ""} { + set from [pid],[thread::id] + } else { + set from [pid] + } + #::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" + return [list ok ""] + } + default { + #autodetect .tm - zip/tar ? + #todo - use vfs ? + + #connect to tarball - start at 1st header + set connected(startdata,$modpodpath) 0 + set fh [open $modpodpath r] + set connected(fh,$modpodpath) $fh + fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} + + if {$connected(startdata,$modpodpath) >= 0} { + #verify we have a valid tar header + if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { + seek $fh $connected(startdata,$modpodpath) start + return [list ok $fh] + } else { + #error "cannot verify tar header" + } + } + lpop connected(to) end + set connected(startdata,$modpodpath) -1 + unset connected(fh,$modpodpath) + catch {close $fh} + return [dict create err {Does not appear to be a valid modpod}] + } + } + } + proc disconnect {{modpod ""}} { + variable connected + if {![llength $connected(to)]} { + return 0 + } + if {$modpod eq ""} { + puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" + set modpod [lindex $connected(to) end] + } + + if {[set posn [lsearch $connected(to) $modpod]] == -1} { + puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" + return 0 + } + if {[string length $connected(fh,$modpod)]} { + close $connected(fh,$modpod) + } + array unset connected *,$modpod + set connected(to) [lreplace $connected(to) $posn $posn] + return 1 + } + proc get {args} { + set argd [punk::args::get_dict { + -from -default "" -help "path to pod" + *values -min 1 -max 1 + filename + } $args] + set frompod [dict get $argd opts -from] + set filename [dict get $argd values filename] + + variable connected + #//review + set modpod [::modpod::system::connect_if_not $frompod] + set fh $connected(fh,$modpod) + if {$connected(type,$modpod) eq "unwrapped"} { + #for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder + if {[string range $filename 0 0 eq "/"]} { + #absolute path (?) + set path [file join $connected(location,$modpod) .. [string trim $filename /]] + } else { + #relative path - use #modpod-xxx as base + set path [file join $connected(location,$modpod) $filename] + } + set fd [open $path r] + #utf-8? + #fconfigure $fd -encoding iso8859-1 -translation binary + return [list ok [lindex [list [read $fd] [close $fd]] 0]] + } else { + #read from vfs + puts stderr "get $filename from wrapped pod '$frompod' not implemented" + } + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace modpod ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval modpod::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace modpod::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + proc is_valid_tm_version {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionparts $versionparts]]} { + return 1 + } else { + return 0 + } + } + + #zipfile is a pure zip at this point - ie no script/exe header + proc make_zip_modpod {args} { + set argd [punk::args::get_dict { + -offsettype -default "archive" -choices {archive file} -help "Whether zip offsets are relative to start of file or start of zip-data within the file. + 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, + but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) + info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. + -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" + *values -min 2 -max 2 + zipfile -type path -minlen 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" + outfile -type path -minlen 1 -help "path to output file. Name should be of the form packagename-version.tm" + } $args] + set zipfile [dict get $argd values zipfile] + set outfile [dict get $argd values outfile] + set opt_offsettype [dict get $argd opts -offsettype] + + + set mount_stub [string map [list %offsettype% $opt_offsettype] { + #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. + #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. + #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% + if {[catch {file normalize [info script]} modfile]} { + error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" + } + if {$modfile eq "" || ![file exists $modfile]} { + error "modpod zip stub error. Unable to determine module path" + } + set moddir [file dirname $modfile] + set mod_and_ver [file rootname [file tail $modfile]] + lassign [split $mod_and_ver -] moduletail version + if {[file exists $moddir/#modpod-$mod_and_ver]} { + source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm + } else { + #determine module namespace so we can mount appropriately + proc intersect {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return {}} + if {[llength $B] > [llength $A]} { + set res $A + set A $B + set B $res + } + set res {} + foreach x $A {set ($x) {}} + foreach x $B { + if {[info exists ($x)]} { + lappend res $x + } + } + return $res + } + set lcase_tmfile_segments [string tolower [file split $moddir]] + set lcase_modulepaths [string tolower [tcl::tm::list]] + foreach lc_mpath $lcase_modulepaths { + set mpath_segments [file split $lc_mpath] + if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { + set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail + break + } + } + if {[llength $tail_segments]} { + set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require + set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver + } else { + set fullpackage $moduletail + set mount_at #modpod/#mounted-modpod-$mod_and_ver + } + + if {[info commands tcl::zipfs::mount] ne ""} { + #argument order changed to be consistent with vfs::zip::Mount etc + #early versions: zipfs::Mount mountpoint zipname + #since 2023-09: zipfs::Mount zipname mountpoint + #don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) + #This is presumably related to // being interpreted as a network path + set mountpoints [dict keys [tcl::zipfs::mount]] + if {"//zipfs:/$mount_at" ni $mountpoints} { + #despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it + if {[catch { + #tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) + #puts "tcl::zipfs::mount $modfile $mount_at" + tcl::zipfs::mount $modfile $mount_at + } errM]} { + #try old api + if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { + puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" + puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" + } + } + if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" + #tcl::zipfs::unmount //zipfs:/$mount_at + error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" + } + } + # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form + source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm + } else { + #fallback to slower vfs::zip + #NB. We don't create the intermediate dirs - but the mount still works + if {![file exists $moddir/$mount_at]} { + if {[catch {package require vfs::zip} errM]} { + set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" + append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." + append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" + error $msg + } else { + set fd [vfs::zip::Mount $modfile $moddir/$mount_at] + if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + vfs::zip::Unmount $fd $moddir/$mount_at + error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" + } + } + } + source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm + } + } + #zipped data follows + }] + #todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? + append mount_stub \x1A + modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype + + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace modpod::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval modpod::system { + #*** !doctools + #[subsection {Namespace modpod::system}] + #[para] Internal functions that are not part of the API + + #deflate,store only supported + + #zipfile here is plain zip - no script/exe prefix part. + proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { + set inzip [open $zipfile r] + fconfigure $inzip -encoding iso8859-1 -translation binary + set out [open $outfile w+] + fconfigure $out -encoding iso8859-1 -translation binary + puts -nonewline $out $mount_stub + set stuboffset [tell $out] + lappend report "stub size: $stuboffset" + fcopy $inzip $out + close $inzip + + set size [tell $out] + lappend report "tmfile : [file tail $outfile]" + lappend report "output size : $size" + lappend report "offsettype : $offsettype" + + if {$offsettype eq "file"} { + #make zip offsets relative to start of whole file including prepended script. + #same offset structure as Tcl's 'zipfs mkimg' as at 2024-10 + #not editable by 7z,nanazip,peazip + + #we aren't adding any new files/folders so we can edit the offsets in place + + #Now seek in $out to find the end of directory signature: + #The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text + if {$size < 65559} { + set tailsearch_start 0 + } else { + set tailsearch_start [expr {$size - 65559}] + } + seek $out $tailsearch_start + set data [read $out] + #EOCD - End of Central Directory record + #PK\5\6 + set start_of_end [string last "\x50\x4b\x05\x06" $data] + #set start_of_end [expr {$start_of_end + $seek}] + #incr start_of_end $seek + set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] + + lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" + + seek $out $filerelative_eocd_posn + set end_of_ctrl_dir [read $out] + binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + + lappend report "End of central directory: [array get eocd]" + seek $out [expr {$filerelative_eocd_posn+16}] + + #adjust offset of start of central directory by the length of our sfx stub + puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] + flush $out + + seek $out $filerelative_eocd_posn + set end_of_ctrl_dir [read $out] + binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + + # 0x06054b50 - end of central dir signature + puts stderr "$end_of_ctrl_dir" + puts stderr "comment_len: $eocd(comment_len)" + puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" + lappend report "New dir offset: $eocd(diroffset)" + lappend report "Adjusting $eocd(totalnum) zip file items." + catch { + punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies + } + + seek $out $eocd(diroffset) + for {set i 0} {$i <$eocd(totalnum)} {incr i} { + set current_file [tell $out] + set fileheader [read $out 46] + puts -------------- + puts [ansistring VIEW -lf 1 $fileheader] + puts -------------- + #binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + # x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + + binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + set ::last_header $fileheader + + puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" + puts "ver: $x(version)" + puts "method: $x(method)" + + #PK\1\2 + #33639248 dec = 0x02014b50 - central directory file header signature + if { $x(sig) != 33639248 } { + error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" + } + + foreach size $x(lengths) var {filename extrafield comment} { + if { $size > 0 } { + set x($var) [read $out $size] + } else { + set x($var) "" + } + } + set next_file [tell $out] + lappend report "file $i: $x(offset) $x(sizes) $x(filename)" + + seek $out [expr {$current_file+42}] + puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] + + #verify: + flush $out + seek $out $current_file + set fileheader [read $out 46] + lappend report "old $x(offset) + $stuboffset" + binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + lappend report "new $x(offset)" + + seek $out $next_file + } + } + + close $out + #pdict/showdict reuire punk & textlib - ie lots of dependencies + #don't fall over just because of that + catch { + punk::lib::showdict -roottype list -chan stderr $report + } + #puts [join $report \n] + return + } + + proc connect_if_not {{podpath ""}} { + upvar ::modpod::connected connected + set podpath [::modpod::system::normalize $podpath] + set docon 0 + if {![llength $connected(to)]} { + if {![string length $podpath]} { + error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" + } else { + set docon 1 + } + } else { + if {![string length $podpath]} { + set podpath [lindex $connected(to) end] + puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" + } else { + if {$podpath ni $connected(to)} { + set docon 1 + } + } + } + if {$docon} { + if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { + error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" + } else { + return $podpath + } + } + #we were already connected + return $podpath + } + + proc myversion {} { + upvar ::modpod::connected connected + set script [info script] + if {![string length $script]} { + error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" + } + set fname [file tail [file rootname [file normalize $script]]] + set scriptdir [file dirname $script] + + if {![string match "#modpod-*" $fname]} { + lassign [lrange [split $fname -] end-1 end] _pkgname version + } else { + lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version + if {![string length $version]} { + #try again on the name of the containing folder + lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version + #todo - proper walk up the directory tree + if {![string length $version]} { + #try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) + lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version + } + } + } + + #tarjar::Log debug "'myversion' determined version for [info script]: $version" + return $version + } + + proc myname {} { + upvar ::modpod::connected connected + set script [info script] + if {![string length $script]} { + error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" + } + return $connected(fullpackage,$script) + } + proc myfullname {} { + upvar ::modpod::connected connected + set script [info script] + #set script [::tarjar::normalize $script] + set script [file normalize $script] + if {![string length $script]} { + error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" + } + return $::tarjar::connected(fullpackage,$script) + } + proc normalize {path} { + #newer versions of Tcl don't do tilde sub + + #Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) + # we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. + set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. + set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after + set path [file normalize $path] + #set path [string tolower $path] ;#must do this after file normalize + return [string map [list $matilda ~] $path] ;#get our tildes back. +} +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide modpod [namespace eval modpod { + variable pkg modpod + variable version + set version 0.1.2 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vendormodules/overtype-1.6.3.tm b/src/vendormodules/overtype-1.6.3.tm deleted file mode 100644 index d7e25d62..00000000 --- a/src/vendormodules/overtype-1.6.3.tm +++ /dev/null @@ -1,3668 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) Julian Noble 2003-2023 -# -# @@ Meta Begin -# Application overtype 1.6.3 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin overtype_module_overtype 0 1.6.3] -#[copyright "2024"] -#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] -#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] -#[require overtype] -#[keywords module text ansi] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of overtype -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by overtype -#[list_begin itemized] - -package require Tcl 8.6- -package require textutil -package require punk::lib ;#required for lines_as_list -package require punk::ansi ;#required to detect, split, strip and calculate lengths -package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars -package require punk::assertion -#*** !doctools -#[item] [package {Tcl 8.6}] -#[item] [package textutil] -#[item] [package punk::ansi] -#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes -#[item] [package punk::char] -#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -#PERFORMANCE notes -#overtype is very performance sensitive - used in ansi output all over the place ie needs to be optimised -#NOTE use of tcl::dict::for tcl::string::range etc instead of ensemble versions. This is for the many tcl 8.6/8.7 interps which don't compile ensemble commands when in safe interps -#similar for tcl::namespace::eval - but this is at least on some versions of Tcl - faster even in a normal interp. Review to see if that holds for Tcl 9. -#for string map: when there are exactly 2 elements - it is faster to use a literal which has a special case optimisation in the c code -#ie use tcl::string::map {\n ""} ... instead of tcl::string::map [list \n ""] ... -#note that we can use unicode (e.g \uFF31) and other escapes such as \t within these curly braces - we don't have to use double quotes -#generally using 'list' is preferred for the map as less error prone. -#can also use: tcl::string::map "token $var" .. but be careful regarding quoting and whitespace in var. This should be used sparingly if at all. - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section API] - - -#Julian Noble - 2003 -#Released under standard 'BSD license' conditions. -# -#todo - ellipsis truncation indicator for center,right - -#v1.4 2023-07 - naive ansi color handling - todo - fix tcl::string::range -# - need to extract and replace ansi codes? - -tcl::namespace::eval overtype { - namespace import ::punk::assertion::assert - punk::assertion::active true - - namespace path ::punk::lib - - namespace export * - variable default_ellipsis_horizontal "..." ;#fallback - variable default_ellipsis_vertical "..." - tcl::namespace::eval priv { - proc _init {} { - upvar ::overtype::default_ellipsis_horizontal e_h - upvar ::overtype::default_ellipsis_vertical e_v - set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis - set e_v [format %c 0x22EE] - #The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text - #Also - unicode ellipsis has semantic meaning that other processors can interpret - #unicode does also provide a midline horizontal ellipsis 0x22EF - - #set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal - #if {![catch {package require punk::char}]} { - # set e [punk::char::charshort boxd_ltdshhz] - #} - } - } - priv::_init -} -proc overtype::about {} { - return "Simple text formatting. Author JMN. BSD-License" -} - -tcl::namespace::eval overtype { - variable grapheme_widths [tcl::dict::create] - - variable escape_terminals - #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - tcl::dict::set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] - #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - tcl::dict::set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals - - #self-contained 2 byte ansi escape sequences - review more? - variable ansi_2byte_codes_dict - set ansi_2byte_codes_dict [tcl::dict::create\ - "reset_terminal" "\u001bc"\ - "save_cursor_posn" "\u001b7"\ - "restore_cursor_posn" "\u001b8"\ - "cursor_up_one" "\u001bM"\ - "NEL - Next Line" "\u001bE"\ - "IND - Down one line" "\u001bD"\ - "HTS - Set Tab Stop" "\u001bH"\ - ] - - #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. - # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ -} - - -#proc overtype::stripansi {text} { -# variable escape_terminals ;#dict -# variable ansi_2byte_codes_dict -# #important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway -# if {[string first \033 $text] <0 && [string first \009c $text] <0} { -# #\033 same as \x1b -# return $text -# } -# -# set text [convert_g0 $text] -# -# #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. -# #line endings can theoretically occur within an ansi escape sequence (review e.g title?) -# set inputlist [split $text ""] -# set outputlist [list] -# -# set 2bytecodes [dict values $ansi_2byte_codes_dict] -# -# set in_escapesequence 0 -# #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls -# set i 0 -# foreach u $inputlist { -# set v [lindex $inputlist $i+1] -# set uv ${u}${v} -# if {$in_escapesequence eq "2b"} { -# #2nd byte - done. -# set in_escapesequence 0 -# } elseif {$in_escapesequence != 0} { -# set escseq [tcl::dict::get $escape_terminals $in_escapesequence] -# if {$u in $escseq} { -# set in_escapesequence 0 -# } elseif {$uv in $escseq} { -# set in_escapseequence 2b ;#flag next byte as last in sequence -# } -# } else { -# #handle both 7-bit and 8-bit CSI and OSC -# if {[regexp {^(?:\033\[|\u009b)} $uv]} { -# set in_escapesequence CSI -# } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { -# set in_escapesequence OSC -# } elseif {$uv in $2bytecodes} { -# #self-contained e.g terminal reset - don't pass through. -# set in_escapesequence 2b -# } else { -# lappend outputlist $u -# } -# } -# incr i -# } -# return [join $outputlist ""] -#} - - - - - -proc overtype::string_columns {text} { - if {[punk::ansi::ta::detect $text]} { - #error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::stripansi. Alternatively try punk::ansi::printing_length" - set text [punk::ansi::stripansi $text] - } - return [punk::char::ansifreestring_width $text] -} - -#todo - consider a way to merge overtype::left/centre/right -#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock -#overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay. -#(i.e not even necessariy having it's top left within the underlay) -tcl::namespace::eval overtype::priv { -} - -#could return larger than colwidth -proc _get_row_append_column {row} { - upvar outputlines outputlines - set idx [expr {$row -1}] - if {$row <= 1 || $row > [llength $outputlines]} { - return 1 - } else { - upvar opt_overflow opt_overflow - upvar colwidth colwidth - set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] - set endpos [expr {$existinglen +1}] - if {$opt_overflow} { - return $endpos - } else { - if {$endpos > $colwidth} { - return $colwidth + 1 - } else { - return $endpos - } - } - } -} - -tcl::namespace::eval overtype { - #*** !doctools - #[subsection {Namespace overtype}] - #[para] Core API functions for overtype - #[list_begin definitions] - - - - #tcl::string::range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r - #render onto an already-rendered (ansi already processed) 'underlay' string, a possibly ansi-laden 'overlay' string. - #The underlay and overlay can be multiline blocks of text of varying line lengths. - #The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. - #This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call. - # a cursor start position other than top-left is a possible addition to consider. - #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline - proc renderspace {args} { - #*** !doctools - #[call [fun overtype::renderspace] [arg args] ] - #[para] usage: ?-transparent [lb]0|1[rb]? ?-overflow [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext - - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext - variable default_ellipsis_horizontal - - if {[llength $args] < 2} { - error {usage: ?-transparent [0|1]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - lassign [lrange $args end-1 end] underblock overblock - set opts [tcl::dict::create\ - -bias ignored\ - -width \uFFEF\ - -height \uFFEF\ - -wrap 0\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -appendlines 1\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -experimental 0\ - -looplimit \uFFEF\ - ] - #-ellipsis args not used if -wrap is true - set argsflags [lrange $args 0 end-2] - foreach {k v} $argsflags { - switch -- $k { - -looplimit - -width - -height - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -appendlines - -transparent - -exposed1 - -exposed2 - -experimental { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::renderspace unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_overflow [tcl::dict::get $opts -overflow] - ##### - # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. - set opt_wrap [tcl::dict::get $opts -wrap] ;#wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) - ##### - #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. - set opt_width [tcl::dict::get $opts -width] - set opt_height [tcl::dict::get $opts -height] - set opt_appendlines [tcl::dict::get $opts -appendlines] - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_exposed1 [tcl::dict::get $opts -exposed1] ;#widechar_exposed_left - todo - set opt_exposed2 [tcl::dict::get $opts -exposed2] ;#widechar_exposed_right - todo - # -- --- --- --- --- --- - - # ---------------------------- - # -experimental dev flag to set flags etc - # ---------------------------- - set data_mode 0 - set test_mode 1 - set info_mode 0 - set edit_mode 0 - set opt_experimental [tcl::dict::get $opts -experimental] - foreach o $opt_experimental { - switch -- $o { - test_mode { - set test_mode 1 - set info_mode 1 - } - old_mode { - set test_mode 0 - set info_mode 1 - } - data_mode { - set data_mode 1 - } - info_mode { - set info_mode 1 - } - edit_mode { - set edit_mode 1 - } - } - } - set test_mode 1 ;#try to eliminate - # ---------------------------- - - #modes - set insert_mode 0 ;#can be toggled by insert key or ansi IRM sequence ESC [ 4 h|l - set autowrap_mode $opt_wrap - set reverse_mode 0 - - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - - #set underlines [split $underblock \n] - - #underblock is a 'rendered' block - so width height make sense - #colwidth & colheight were originally named with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. - #The naming is now confusing. It should be something like renderwidth renderheight ?? review - - if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { - lassign [blocksize $underblock] _w colwidth _h colheight - if {$opt_width ne "\uFFEF"} { - set colwidth $opt_width - } - if {$opt_height ne "\uFFEF"} { - set colheight $opt_height - } - } else { - set colwidth $opt_width - set colheight $opt_height - } - - # -- --- --- --- - #REVIEW - do we need ansi resets in the underblock? - if {$underblock eq ""} { - set underlines [lrepeat $colheight ""] - } else { - set underlines [split $underblock \n] - } - #if {$underblock eq ""} { - # set blank "\x1b\[0m\x1b\[0m" - # #set underlines [list "\x1b\[0m\x1b\[0m"] - # set underlines [lrepeat $colheight $blank] - #} else { - # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW - # set underlines [lines_as_list -ansiresets 1 $underblock] - #} - # -- --- --- --- - - #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. - #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output colwidth - #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. - #(in cases where there are interline moves or cursor jumps anyway) - #This works - but doesn't seem efficient. - #On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first - - #a hack until we work out how to avoid infinite loops... - # - set looplimit [tcl::dict::get $opts -looplimit] - if {$looplimit eq "\uFFEF"} { - #looping for each char is worst case (all newlines?) - anything over that is an indication of something broken? - #do we need any margin above the length? (telnet mapscii.me test) - set looplimit [expr {[string length $overblock] + 10}] - } - - if {!$test_mode} { - set inputchunks [split $overblock \n] - } else { - set scheme 3 - switch -- $scheme { - 0 { - #one big chunk - set inputchunks [list $overblock] - } - 1 { - set inputchunks [punk::ansi::ta::split_codes $overblock] - } - 2 { - - #split into lines if possible first - then into plaintext/ansi-sequence chunks ? - set inputchunks [list ""] ;#put an empty plaintext split in for starters - set i 1 - set lines [split $overblock \n] - foreach ln $lines { - if {$i < [llength $lines]} { - append ln \n - } - set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? - set lastpt [lindex $inputchunks end] - lset inputchunks end [tcl::string::cat $lastpt [lindex $sequence_split 0]] - lappend inputchunks {*}[lrange $sequence_split 1 end] - incr i - } - } - 3 { - #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice - set lflines [list] - set inputchunks [split $overblock \n] - foreach ln $inputchunks { - append ln \n - lappend lflines $ln - } - if {[llength $lflines]} { - lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] - } - set inputchunks $lflines[unset lflines] - - } - } - } - - - #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height - #lassign [blocksize $overblock] _w overblock_width _h overblock_height - - - set replay_codes_underlay [tcl::dict::create 1 ""] - #lappend replay_codes_overlay "" - set replay_codes_overlay "" - set unapplied "" - set cursor_saved_position [tcl::dict::create] - set cursor_saved_attributes "" - - - set outputlines $underlines - set overidx 0 - - #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext - set row 1 - if {$data_mode} { - set col [_get_row_append_column $row] - } else { - set col 1 - } - - set instruction_stats [tcl::dict::create] - - set loop 0 - #while {$overidx < [llength $inputchunks]} { } - - while {[llength $inputchunks]} { - #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" - set overtext [lpop inputchunks 0] - if {![string length $overtext]} { - incr loop - continue - } - #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" - set undertext [lindex $outputlines [expr {$row -1}]] - set renderedrow $row - - #renderline pads each underaly line to width with spaces and should track where end of data is - - - #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] - if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [tcl::string::cat [tcl::dict::get $replay_codes_underlay $row] $undertext] - } - #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l - set LASTCALL [list -info 1 -insert_mode $insert_mode -autowrap_mode $autowrap_mode -transparent $opt_transparent -width $colwidth -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -cursor_column $col -cursor_row $row $undertext $overtext] - set rinfo [renderline -experimental $opt_experimental\ - -info 1\ - -insert_mode $insert_mode\ - -cursor_restore_attributes $cursor_saved_attributes\ - -autowrap_mode $autowrap_mode\ - -transparent $opt_transparent\ - -width $colwidth\ - -exposed1 $opt_exposed1\ - -exposed2 $opt_exposed2\ - -overflow $opt_overflow\ - -cursor_column $col\ - -cursor_row $row\ - $undertext\ - $overtext\ - ] - set instruction [tcl::dict::get $rinfo instruction] - set insert_mode [tcl::dict::get $rinfo insert_mode] - set autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;# - #set reverse_mode [tcl::dict::get $rinfo reverse_mode];#how to support in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? - set rendered [tcl::dict::get $rinfo result] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set overflow_right_column [tcl::dict::get $rinfo overflow_right_column] - set unapplied [tcl::dict::get $rinfo unapplied] - set unapplied_list [tcl::dict::get $rinfo unapplied_list] - set post_render_col [tcl::dict::get $rinfo cursor_column] - set post_render_row [tcl::dict::get $rinfo cursor_row] - set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position] - set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes] - set visualwidth [tcl::dict::get $rinfo visualwidth] - set insert_lines_above [tcl::dict::get $rinfo insert_lines_above] - set insert_lines_below [tcl::dict::get $rinfo insert_lines_below] - tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay] - #lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - - - - #-- todo - detect looping properly - if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { - puts stderr "overtype::renderspace loop?" - puts [ansistring VIEW $rinfo] - break - } - #-- - - if {[tcl::dict::size $c_saved_pos] >= 1} { - set cursor_saved_position $c_saved_pos - set cursor_saved_attributes $c_saved_attributes - } - - - set overflow_handled 0 - - - - set nextprefix "" - - - #todo - handle potential insertion mode as above for cursor restore? - #keeping separate branches for debugging - review and merge as appropriate when stable - tcl::dict::incr instruction_stats $instruction - switch -- $instruction { - {} { - if {$test_mode == 0} { - incr row - if {$data_mode} { - set col [_get_row_append_column $row] - if {$col > $colwidth} { - - } - } else { - set col 1 - } - } else { - #lf included in data - set row $post_render_row - set col $post_render_col - - #set col 1 - #if {$post_render_row != $renderedrow} { - # set col 1 - #} else { - # set col $post_render_col - #} - } - } - up { - - #renderline knows it's own line number, and knows not to go above row l - #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. - #row returned should be correct. - #column may be the overflow column - as it likes to report that to the caller. - - #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. - #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review - #puts stderr "up $post_render_row" - #puts stderr "$rinfo" - - #puts stdout "1 row:$row col $col" - set row $post_render_row - #data_mode (naming?) determines if we move to end of existing data or not. - #data_mode 0 means ignore existing line length and go to exact column - #set by -experimental flag - if {$data_mode == 0} { - set col $post_render_col - } else { - #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data - #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $colwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $colwidth - } - } - - #puts stdout "2 row:$row col $col" - #puts stdout "-----------------------" - #puts stdout $rinfo - #flush stdout - } - down { - if {$data_mode == 0} { - #renderline doesn't know how far down we can go.. - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } - set row $post_render_row - set col $post_render_col - } else { - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $colwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $colwidth - } - - } - } - restore_cursor { - #testfile belinda.ans uses this - - #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" - if {[tcl::dict::exists $cursor_saved_position row]} { - set row [tcl::dict::get $cursor_saved_position row] - set col [tcl::dict::get $cursor_saved_position column] - #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" - #set nextprefix $cursor_saved_attributes - #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes - #set replay_codes_overlay $cursor_saved_attributes - set cursor_saved_position [tcl::dict::create] - set cursor_saved_attributes "" - } else { - #TODO - #?restore without save? - #should move to home position and reset ansi SGR? - #puts stderr "overtype::renderspace cursor_restore without save data available" - } - #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it - #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. - if {!$overflow_handled && $overflow_right ne ""} { - #wrap before restore? - possible effect on saved cursor position - #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc - #we can just insert another call to renderline to solve this.. ? - #It would perhaps be more properly handled as a queue of instructions from our initial renderline call - #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks - - puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" - - set sub_info [overtype::renderline -info 1 -width $colwidth -insert_mode $insert_mode -autowrap_mode $autowrap_mode -overflow [tcl::dict::get $opts -overflow] "" $overflow_right] - set foldline [tcl::dict::get $sub_info result] - set insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed.. - set autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. - linsert outputlines $renderedrow $foldline - #review - row & col set by restore - but not if there was no save.. - } - set overflow_handled 1 - - } - move { - ######## - if {$post_render_row > [llength $outputlines]} { - #Ansi moves need to create new lines ? - #if {$opt_appendlines} { - # set diff [expr {$post_render_row - [llength $outputlines]}] - # if {$diff > 0} { - # lappend outputlines {*}[lrepeat $diff ""] - # } - # set row $post_render_row - #} else { - set row [llength $outputlines] - #} - } else { - set row $post_render_row - } - ####### - set col $post_render_col - #overflow + unapplied? - } - lf_start { - #raw newlines - must be test_mode - # ---------------------- - #test with fruit.ans - #test - treating as newline below... - #append rendered $overflow_right - #set overflow_right "" - set row $renderedrow - incr row - if {$row > [llength $outputlines]} { - lappend outputlines "" - } - set col 1 - # ---------------------- - } - lf_mid { - - if 0 { - #set rhswidth [punk::ansi::printing_length $overflow_right] - #only show debug when we have overflow? - set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] - set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] - - set rhs "" - if {$overflow_right ne ""} { - set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $overflow_right]] - set rhs [textblock::frame -title overflow_right $rhs] - } - puts [textblock::join $lhs " $post_render_col " $rhs] - } - - if {!$test_mode} { - #rendered - append rendered $overflow_right - #set replay_codes_overlay "" - set overflow_right "" - - - set row $renderedrow - - set col 1 - incr row - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - set edit_mode 0 - if {$edit_mode} { - set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] - set overflow_right "" - set unapplied "" - set row $post_render_row - #set col $post_render_col - set col 1 - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - append rendered $overflow_right - set overflow_right "" - set row $post_render_row - set col 1 - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } - } - } - lf_overflow { - #linefeed after colwidth e.g at column 81 for an 80 col width - #we may also have other control sequences that came after col 80 e.g cursor save - - if 0 { - set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] - set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] - set rhs "" - - #assertion - there should be no overflow.. - puts $lhs - } - assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right - - set row $post_render_row - #set row $renderedrow - #incr row - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - set col 1 - - } - newlines_above { - #we get a newlines_above instruction when received at column 1 - #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) - #in other cases - we want to treat at column 1 the same as any other - - puts "--->newlines_above" - puts "rinfo: $rinfo" - #renderline doesn't advance the row for us - the caller has the choice to implement or not - set row $post_render_row - set col $post_render_col - if {$insert_lines_above > 0} { - set row $renderedrow - set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] - incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above - #? set row $post_render_row #can renderline tell us? - } - } - newlines_below { - #obsolete? - use for ANSI insert lines sequence - if {$data_mode == 0} { - puts --->nl_below - set row $post_render_row - set col $post_render_col - if {$insert_lines_below == 1} { - if {$test_mode == 0} { - set row $renderedrow - set outputlines [linsert $outputlines [expr {$renderedrow }] {*}[lrepeat $insert_lines_below ""]] ;#note - linsert can add to end too - incr row $insert_lines_below - set col 1 - } else { - #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] - #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] - #set rhs "" - #if {$overflow_right ne ""} { - # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] - # set rhs [textblock::frame -title overflow_right $rhs] - #} - #puts [textblock::join $lhs $rhs] - - #rendered - append rendered $overflow_right - # - - - set overflow_right "" - set row $renderedrow - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat $insert_lines_below ""] - } - incr row $insert_lines_below - set col 1 - - - - } - } - } else { - set row $post_render_row - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } else { - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $colwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $colwidth - } - } - } - } - wrapmoveforward { - #doesn't seem to be used by fruit.ans testfile - #used by dzds.ans - #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO - set c $colwidth - set r $post_render_row - if {$post_render_col > $colwidth} { - set i $c - while {$i <= $post_render_col} { - if {$c == $colwidth+1} { - incr r - if {$opt_appendlines} { - if {$r < [llength $outputlines]} { - lappend outputlines "" - } - } - set c 1 - } else { - incr c - } - incr i - } - set col $c - } else { - #why are we getting this instruction then? - puts stderr "wrapmoveforward - test" - set r [expr {$post_render_row +1}] - set c $post_render_col - } - set row $r - set col $c - } - wrapmovebackward { - set c $colwidth - set r $post_render_row - if {$post_render_col < 1} { - set c 1 - set i $c - while {$i >= $post_render_col} { - if {$c == 0} { - if {$r > 1} { - incr r -1 - set c $colwidth - } else { - #leave r at 1 set c 1 - #testfile besthpav.ans first line top left border alignment - set c 1 - break - } - } else { - incr c -1 - } - incr i -1 - } - set col $c - } else { - puts stderr "Wrapmovebackward - but postrendercol >= 1???" - } - set row $r - set col $c - } - overflow { - #normal single-width grapheme overflow - #puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" - set row $post_render_row ;#renderline will not advance row when reporting overflow char - if {$autowrap_mode} { - incr row - set col 1 ;#whether wrap or not - next data is at column 1 ?? - } else { - #this works for test_mode (which should become the default) - but could give a bad result otherwise - review - add tests fix. - set col $post_render_col - #set unapplied "" ;#this seems wrong? - #set unapplied [tcl::string::range $unapplied 1 end] - #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs - #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate - #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' - set idx 0 - set next_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set next_grapheme_index $idx - break - } - incr idx - } - assert {$next_grapheme_index >= 0} - #drop the overflow grapheme - keeping all codes in place. - set unapplied [join [lreplace $unapplied_list $next_grapheme_index $next_grapheme_index] ""] - #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines - - set overflow_handled 1 - #handled by dropping overflow if any - } - } - overflow_splitchar { - set row $post_render_row ;#renderline will not advance row when reporting overflow char - - #2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts - #todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc - if {$autowrap_mode} { - if {$colwidth < 2} { - #edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } else { - set col 1 - incr row - } - } else { - set overflow_handled 1 - #handled by dropping entire overflow if any - if {$colwidth < 2} { - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } - } - - } - vt { - - #can vt add a line like a linefeed can? - set row $post_render_row - set col $post_render_col - } - default { - puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'" - } - - } - - - if {!$opt_overflow && !$autowrap_mode} { - #not allowed to overflow column or wrap therefore we get overflow data to truncate - if {[tcl::dict::get $opts -ellipsis]} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim [punk::ansi::stripansi $lostdata]] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::right $rendered $opt_ellipsistext] - } - set overflow_handled 1 - } else { - #no wrap - no ellipsis - silently truncate - set overflow_handled 1 - } - } - - - - if {$renderedrow <= [llength $outputlines]} { - lset outputlines [expr {$renderedrow-1}] $rendered - } else { - if {$opt_appendlines} { - lappend outputlines $rendered - } else { - #? - lset outputlines [expr {$renderedrow-1}] $rendered - } - } - - if {!$overflow_handled} { - append nextprefix $overflow_right - } - - append nextprefix $unapplied - - if 0 { - if {$nextprefix ne ""} { - set nextoveridx [expr {$overidx+1}] - if {$nextoveridx >= [llength $inputchunks]} { - lappend inputchunks $nextprefix - } else { - #lset overlines $nextoveridx $nextprefix[lindex $overlines $nextoveridx] - set inputchunks [linsert $inputchunks $nextoveridx $nextprefix] - } - } - } - - if {$nextprefix ne ""} { - set inputchunks [linsert $inputchunks 0 $nextprefix] - } - - - incr overidx - incr loop - if {$loop >= $looplimit} { - puts stderr "overtype::renderspace looplimit reached ($looplimit)" - lappend outputlines "[a+ red bold] - looplimit $looplimit reached[a]" - set Y [a+ yellow bold] - set RST [a] - set sep_header ----DEBUG----- - set debugmsg "" - append debugmsg "${Y}${sep_header}${RST}" \n - append debugmsg "looplimit $looplimit reached\n" - append debugmsg "test_mode:$test_mode\n" - append debugmsg "data_mode:$data_mode\n" - append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[tcl::dict::get $LASTCALL -cursor_row]\n" - append debugmsg "prev_col :[tcl::dict::get $LASTCALL -cursor_column]\n" - tcl::dict::for {k v} $rinfo { - append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n - } - append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n - - puts stdout $debugmsg - #todo - config regarding error dumps rather than just dumping in working dir - set fd [open [pwd]/error_overtype.txt w] - puts $fd $debugmsg - close $fd - error $debugmsg - break - } - } - - set result [join $outputlines \n] - if {$info_mode} { - #emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window? - #append result \n$instruction_stats\n - } - return $result - } - - #todo - left-right ellipsis ? - proc centre {args} { - variable default_ellipsis_horizontal - if {[llength $args] < 2} { - error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} - } - - foreach {underblock overblock} [lrange $args end-1 end] break - - #todo - vertical vs horizontal overflow for blocks - set opts [tcl::dict::create\ - -bias left\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - ] - set argsflags [lrange $args 0 end-2] - foreach {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - # -- --- --- --- --- --- - - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w colwidth _h colheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {$colwidth - $overblock_width}] - if {$under_exposed_max > 0} { - #background block is wider - if {$under_exposed_max % 2 == 0} { - #even left/right exposure - set left_exposed [expr {$under_exposed_max / 2}] - } else { - set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division - if {[tcl::string::tolower [tcl::dict::get $opts -bias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $colwidth} { - set udiff [expr {$colwidth - $ulen}] - set undertext "$undertext[string repeat { } $udiff]" - } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] - - set overflowlength [expr {$overtext_datalen - $colwidth}] - #review - right-to-left langs should elide on left! - extra option required - - if {$overflowlength > 0} { - #overlay line wider or equal - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - set rendered [tcl::dict::get $rinfo result] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set unapplied [tcl::dict::get $rinfo unapplied] - #todo - get replay_codes from overflow_right instead of wherever it was truncated? - - #overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified - if {![tcl::dict::get $opts -overflow]} { - #lappend outputlines [tcl::string::range $overtext 0 [expr {$colwidth - 1}]] - #set overtext [tcl::string::range $overtext 0 $colwidth-1 ] - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - #don't use tcl::string::range on ANSI data - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::right $rendered $opt_ellipsistext] - } - } - } - lappend outputlines $rendered - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent $undertext $overtext] - } else { - #background block is wider than or equal to data for this line - #lappend outputlines [renderline -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - set rinfo [renderline -info 1 -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - lappend outputlines [tcl::dict::get $rinfo result] - } - set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - } - return [join $outputlines \n] - } - - #overtype::right is for a rendered ragged underblock and a rendered ragged overblock - #ie we can determine the block width for bost by examining the lines and picking the longest. - # - proc right {args} { - #NOT the same as align-right - which should be done to the overblock first if required - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? ?-transparent 0|? undertext overtext} - } - foreach {underblock overblock} [lrange $args end-1 end] break - - set opts [tcl::dict::create\ - -bias ignored\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -align "left"\ - ] - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_overflow [tcl::dict::get $opts -overflow] - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - set opt_align [tcl::dict::get $opts -align] - # -- --- --- --- --- --- - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w colwidth _h colheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {max(0,$colwidth - $overblock_width)}] - set left_exposed $under_exposed_max - - - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $colwidth} { - set udiff [expr {$colwidth - $ulen}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_align { - left { - set startoffset 0 - } - right { - set startoffset $odiff - } - default { - set half [expr {$odiff / 2}] - #set lhs [string repeat { } $half] - #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left - #set rhs [string repeat { } $righthalf] - set startoffset $half - } - } - } else { - set startoffset 0 ;#negative? - } - - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] - - set overflowlength [expr {$overtext_datalen - $colwidth}] - if {$overflowlength > 0} { - #raw overtext wider than undertext column - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] - set replay_codes [tcl::dict::get $rinfo replay_codes] - set rendered [tcl::dict::get $rinfo result] - if {!$opt_overflow} { - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] - #todo - overflow on left if allign = right?? - set rendered [overtype::right $rendered $ellipsis] - } - } - } - lappend outputlines $rendered - } else { - #padded overtext - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need overflow here - as although the overtext is short - it may oveflow due to the startoffset - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - lappend outputlines [tcl::dict::get $rinfo result] - } - set replay_codes [tcl::dict::get $rinfo replay_codes] - set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - } - - return [join $outputlines \n] - } - - proc left {args} { - overtype::block -blockalign left {*}$args - } - #overtype a (possibly ragged) underblock with a (possibly ragged) overblock - proc block {args} { - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-blockalign left|centre|right? ?-textalign left|centre|right? ?-overflow [1|0]? ?-transparent 0|? undertext overtext} - } - foreach {underblock overblock} [lrange $args end-1 end] break - - set defaults [tcl::dict::create\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -textalign "left"\ - -textvertical "top"\ - -blockalign "left"\ - -blockalignbias left\ - -blockvertical "top"\ - ] - set argsflags [lrange $args 0 end-2] - set opts $defaults - tcl::dict::for {k v} $argsflags { - switch -- $k { - -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $defaults] - error "overtype::block unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_overflow [tcl::dict::get $opts -overflow] - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - set opt_textalign [tcl::dict::get $opts -textalign] - set opt_blockalign [tcl::dict::get $opts -blockalign] - if {$opt_blockalign eq "center"} { - set opt_blockalign "centre" - } - # -- --- --- --- --- --- - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w colwidth _h colheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {max(0,$colwidth - $overblock_width)}] - - switch -- $opt_blockalign { - left { - set left_exposed 0 - } - right { - set left_exposed $under_exposed_max - } - centre { - if {$under_exposed_max > 0} { - #background block is wider - if {$under_exposed_max % 2 == 0} { - #even left/right exposure - set left_exposed [expr {$under_exposed_max / 2}] - } else { - set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division - if {[tcl::string::tolower [tcl::dict::get $opts -blockalignbias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - } - default { - set left_exposed 0 - } - } - - - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $colwidth} { - set udiff [expr {$colwidth - $ulen}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_textalign { - left { - set startoffset 0 - } - right { - set startoffset $odiff - } - default { - set half [expr {$odiff / 2}] - #set lhs [string repeat { } $half] - #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left - #set rhs [string repeat { } $righthalf] - set startoffset $half - } - } - } else { - set startoffset 0 ;#negative? - } - - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] - - set overflowlength [expr {$overtext_datalen - $colwidth}] - if {$overflowlength > 0} { - #raw overtext wider than undertext column - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] - set replay_codes [tcl::dict::get $rinfo replay_codes] - set rendered [tcl::dict::get $rinfo result] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set unapplied [tcl::dict::get $rinfo unapplied] - if {!$opt_overflow} { - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - #don't use tcl::string::range on ANSI data - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::block -blockalign right $rendered $opt_ellipsistext] - } - } - - #if {$opt_ellipsis} { - # set show_ellipsis 1 - # if {!$opt_ellipsiswhitespace} { - # #we don't want ellipsis if only whitespace was lost - # set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - # if {[tcl::string::trim $lostdata] eq ""} { - # set show_ellipsis 0 - # } - # } - # if {$show_ellipsis} { - # set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] - # #todo - overflow on left if allign = right?? - # set rendered [overtype::right $rendered $ellipsis] - # } - #} - } - lappend outputlines $rendered - } else { - #padded overtext - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need overflow here - as although the overtext is short - it may oveflow due to the startoffset - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set unapplied [tcl::dict::get $rinfo unapplied] - lappend outputlines [tcl::dict::get $rinfo result] - } - set replay_codes [tcl::dict::get $rinfo replay_codes] - set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - } - - return [join $outputlines \n] - } - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. - # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # - # - #-returnextra enables returning of overflow and length - #review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation? - #review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements - #(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char) - #todo - review transparency issues with single/double width characters - #bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer? - proc renderline {args} { - #*** !doctools - #[call [fun overtype::renderline] [arg args] ] - #[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell - #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts - #[para] This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that can be joined & framed for layout display within a unix or windows terminal - #[para] Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't affect another. - #[para] Calling on the punk::ansi library - it can coalesce codes to keep the size down. - #[para] It is a giant mess of doing exactly what common wisdom says not to do... lots at once. - #[para] renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a static underlay - #[para] The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous to a terminal screen - but it can also be ragged in line length, or just blank. - #[para] The overlay couuld be similar - in which case it may often be used to overwrite a column or section of the underlay. - #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. - # - #[para] renderline itself only deals with a single line - or sometimes a single character. It is generally called from a loop that does further terminal-like or textblock processing. - #[para] By suppyling the -info 1 option - it can return various fields indicating the state of the render. - #[para] The main 3 are the result, overflow_right, and unapplied. - #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. - - if {[llength $args] < 2} { - error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-overflow [1|0]? undertext overtext} - } - lassign [lrange $args end-1 end] under over - if {[string first \n $under] >= 0} { - error "overtype::renderline not allowed to contain newlines in undertext" - } - #if {[string first \n $over] >=0 || [string first \n $under] >= 0} { - # error "overtype::renderline not allowed to contain newlines" - #} - - set defaults [tcl::dict::create\ - -etabs 0\ - -width \uFFEF\ - -overflow 0\ - -transparent 0\ - -startcolumn 1\ - -cursor_column 1\ - -cursor_row ""\ - -insert_mode 1\ - -autowrap_mode 1\ - -reverse_mode 0\ - -info 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -cursor_restore_attributes ""\ - -cp437 0\ - -experimental {}\ - ] - #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller - - #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return - #An empty string for cursor_row tells us we have no info about our own row context, and to return with an unapplied string if any row move occurs - - #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency or overflow - #todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error - - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -experimental - -cp437 - -width - -overflow - -transparent - -startcolumn - -cursor_column - -cursor_row - -insert_mode - -autowrap_mode - -reverse_mode - -info - -exposed1 - -exposed2 - -cursor_restore_attributes {} - default { - set known_opts [tcl::dict::keys $defaults] - error "overtype::renderline unknown option '$k'. Known options: $known_opts" - } - } - } - set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_width [tcl::dict::get $opts -width] - set opt_etabs [tcl::dict::get $opts -etabs] - set opt_overflow [tcl::dict::get $opts -overflow] - set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay - set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay - set opt_row_context [tcl::dict::get $opts -cursor_row] - if {[string length $opt_row_context]} { - if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } { - error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) - set opt_insert_mode [tcl::dict::get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) - #default is for overtype - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_autowrap_mode [tcl::dict::get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line - set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] ;#DECSNM - # -- --- --- --- --- --- --- --- --- --- --- --- - set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] - - set test_mode 0 - set cp437_glyphs [tcl::dict::get $opts -cp437] - foreach e [tcl::dict::get $opts -experimental] { - switch -- $e { - test_mode { - set test_mode 1 - set cp437_glyphs 1 - } - } - } - set test_mode 1 ;#try to elminate - set cp437_map [tcl::dict::create] - if {$cp437_glyphs} { - set cp437_map [set ::punk::ansi::cp437_map] - #for cp437 images we need to map these *after* splitting ansi - #some old files might use newline for its glyph.. but we can't easily support that. - #Not sure how old files did it.. maybe cr lf in sequence was newline and any lone cr or lf were displayed as glyphs? - tcl::dict::unset cp437_map \n - } - - set opt_transparent [tcl::dict::get $opts -transparent] - if {$opt_transparent eq "0"} { - set do_transparency 0 - } else { - set do_transparency 1 - if {$opt_transparent eq "1"} { - set opt_transparent {[\s]} - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_returnextra [tcl::dict::get $opts -info] - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - # -- --- --- --- --- --- --- --- --- --- --- --- - - if {$opt_row_context eq ""} { - set cursor_row 1 - } else { - set cursor_row $opt_row_context - } - - - #----- - # - if {[info exists punk::console::tabwidth]} { - #punk console is updated if punk::console::set_tabstop_width is used or rep is started/restarted - #It is way too slow to test the current width by querying the terminal here - so it could conceivably get out of sync - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - - set overdata $over - if {!$cp437_glyphs} { - #REVIEW! tabify will give different answers for an ANSI colourised string vs plain text - if {!$opt_etabs} { - if {[string first \t $under] >= 0} { - #set under [textutil::tabify::untabify2 $under] - set under [textutil::tabify::untabifyLine $under $tw] - } - if {[string first \t $over] >= 0} { - #set overdata [textutil::tabify::untabify2 $over] - set overdata [textutil::tabify::untabifyLine $over $tw] - } - } - } - #------- - - #ta_detect ansi and do simpler processing? - - #we repeat tests for grapheme width in different loops - rather than create another datastructure to store widths based on column, - #we'll use the grapheme_width_cached function as a lookup table of all graphemes encountered - as there will often be repeats in different positions anyway. - - # -- --- --- --- --- --- --- --- - if {$under ne ""} { - set undermap [punk::ansi::ta::split_codes_single $under] - } else { - set undermap [list] - } - set understacks [list] - set understacks_gx [list] - - set i_u -1 ;#underlay may legitimately be empty - set undercols [list] - set u_codestack [list] - #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway - set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) - #set pt_underchars "" ;#for string_columns length calculation for overflow 0 truncation - set remainder [list] ;#for returnextra - foreach {pt code} $undermap { - #pt = plain text - #append pt_underchars $pt - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - foreach grapheme [punk::char::grapheme_split $pt] { - #an ugly hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. - #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. - switch -- $grapheme { - " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - set width 1 - } - default { - if {$grapheme eq "\u0000"} { - #use null as empty cell representation - review - #use of this will probably collide with some application at some point - #consider an option to set the empty cell character - set width 1 - } else { - set width [grapheme_width_cached $grapheme] - #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length - #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI - #todo - default to off and add a flag (?) to enable this substitution - set sub_stray_escapes 0 - if {$sub_stray_escapes && $width == 0} { - if {$grapheme eq "\x1b"} { - set gvis [ansistring VIEW $grapheme] - set grapheme $gvis - set width 1 - } - } - } - } - } - #set width [grapheme_width_cached $grapheme] - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - - lappend undercols $grapheme - if {$width > 1} { - #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) - #but what about emoji combinations etc - can they be wider than 2? - #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - lappend undercols "" - } - } - - #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here - - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc - if {$code ne ""} { - set c1c2 [tcl::string::range $code 0 1] - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars - - switch -- $leadernorm { - 7CSI - 8CSI { - #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse - #REVIEW - what else could end in m but be mistaken as a normal SGR code here? - set maybemouse "" - if {[tcl::string::index $c1c2 0] eq "\x1b"} { - set maybemouse [tcl::string::index $code 2] - } - - if {$maybemouse ne "<" && [tcl::string::index $code end] eq "m"} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set u_codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set u_codestack [list $code] - } else { - #basic simplification first.. straight dups - set dup_posns [lsearch -all -exact $u_codestack $code] ;#-exact because of square-bracket glob chars - set u_codestack [lremove $u_codestack {*}$dup_posns] - lappend u_codestack $code - } - } - } - 7GFX { - switch -- [tcl::string::index $code 2] { - "0" { - set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess - } - B { - set u_gx_stack [list] - } - } - } - default { - - } - - } - - #if {[punk::ansi::codetype::is_sgr_reset $code]} { - # #set u_codestack [list] - #} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - #} elseif {[punk::ansi::codetype::is_sgr $code]} { - #} else { - # #leave SGR stack as is - # if {[punk::ansi::codetype::is_gx_open $code]} { - # } elseif {[punk::ansi::codetype::is_gx_close $code]} { - # } - #} - } - #consider also if there are other codes that should be stacked..? - } - - if {!$test_mode} { - #fill columns to width with spaces, and carry over stacks - we will have to keep track of where the underlying data ends manually - TODO - #Specifying a width is suitable for terminal-like applications and text-blocks - if {$opt_width ne "\uFFEF"} { - if {[llength $understacks]} { - set cs $u_codestack - set gs $u_gx_stack - } else { - set cs [list] - set gs [list] - } - if {[llength $undercols]< $opt_width} { - set diff [expr {$opt_width- [llength $undercols]}] - if {$diff > 0} { - lappend undercols {*}[lrepeat $diff " "] - lappend understacks {*}[lrepeat $diff $cs] - lappend understacks_gx {*}[lrepeat $diff $gs] - } - } - } - } else { - #NULL empty cell indicator - if {$opt_width ne "\uFFEF"} { - if {[llength $understacks]} { - set cs $u_codestack - set gs $u_gx_stack - } else { - set cs [list] - set gs [list] - } - if {[llength $undercols]< $opt_width} { - set diff [expr {$opt_width- [llength $undercols]}] - if {$diff > 0} { - lappend undercols {*}[lrepeat $diff "\u0000"] - lappend understacks {*}[lrepeat $diff $cs] - lappend understacks_gx {*}[lrepeat $diff $gs] - } - } - } - - } - if {$opt_width ne "\uFFEF"} { - set colwidth $opt_width - } else { - set colwidth [llength $undercols] - } - - - if 0 { - # ----------------- - # if we aren't extending understacks & understacks_gx each time we incr idx above the undercols length.. this doesn't really serve a purpose - # Review. - # ----------------- - #replay code for last overlay position in input line - # whether or not we get that far - we need to return it for possible replay on next line - if {[llength $understacks]} { - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - } else { - #in case overlay onto emptystring as underlay - lappend understacks [list] - lappend understacks_gx [list] - } - # ----------------- - } - - #trailing codes in effect for underlay - if {[llength $u_codestack]} { - #set replay_codes_underlay [join $u_codestack ""] - set replay_codes_underlay [punk::ansi::codetype::sgr_merge_list {*}$u_codestack] - } else { - set replay_codes_underlay "" - } - - - # -- --- --- --- --- --- --- --- - #### - #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left of the right number of columns. - #this will be processed as transparent - and handle doublewidth underlay characters appropriately - set startpad_overlay [string repeat " " [expr {$opt_colstart -1}]] - append startpad_overlay $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] - #### - - #??? - set colcursor $opt_colstart - #TODO - make a little virtual column object - #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn - #need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess. - - - #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} - #as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes - - set overstacks [list] - set overstacks_gx [list] - - set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc) - set o_gxstack [list] - set pt_overchars "" - set i_o 0 - set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use - #experiment - set overlay_grapheme_control_stacks [list] - foreach {pt code} $overmap { - - #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - append pt_overchars $pt - #will get empty pt between adjacent codes - foreach grapheme [punk::char::grapheme_split $pt] { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack - } - - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc - #order of if-else based on assumptions: - # that pure resets are fairly common - more so than leading resets with other info - # that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. - if {$code ne ""} { - lappend overlay_grapheme_control_stacks $o_codestack - #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set o_codestack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars - set o_codestack [lremove $o_codestack {*}$dup_posns] - lappend o_codestack $code - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[regexp {\x1b7|\x1b\[s} $code]} { - #experiment - #cursor_save - for the replays review. - #jmn - #set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - lappend overlay_grapheme_control_list [list other $code] - } elseif {[regexp {\x1b8|\x1b\[u} $code]} { - #experiment - #cursor_restore - for the replays - set o_codestack [list $temp_cursor_saved] - lappend overlay_grapheme_control_list [list other $code] - } else { - if {[punk::ansi::codetype::is_gx_open $code]} { - set o_gxstack [list "gx0_on"] - lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } elseif {[punk::ansi::codetype::is_gx_close $code]} { - set o_gxstack [list] - lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } else { - lappend overlay_grapheme_control_list [list other $code] - } - } - } - - } - #replay code for last overlay position in input line - should take account of possible trailing sgr code after last grapheme - set max_overlay_grapheme_index [expr {$i_o -1}] - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - - #set replay_codes_overlay [join $o_codestack ""] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - - #if {[tcl::dict::exists $overstacks $max_overlay_grapheme_index]} { - # set replay_codes_overlay [join [tcl::dict::get $overstacks $max_overlay_grapheme_index] ""] - #} else { - # set replay_codes_overlay "" - #} - # -- --- --- --- --- --- --- --- - - - #potential problem - combinining diacritics directly following control chars like \r \b - - # -- --- --- - #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 - if {$opt_overflow} { - #somewhat counterintuitively - overflow true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. - set overflow_idx -1 - } else { - #overflow zero - we can't grow beyond our column width - so we get ellipsis or truncation - if {$opt_width ne "\uFFEF"} { - set overflow_idx [expr {$opt_width}] - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - } - # -- --- --- - - set outcols $undercols ;#leave undercols as is, outcols can potentially be appended to. - - set unapplied "" ;#if we break for move row (but not for /v ?) - set unapplied_list [list] - - set insert_lines_above 0 ;#return key - set insert_lines_below 0 - set instruction "" - - # -- --- --- - #cursor_save_dec, cursor_restore_dec etc - set cursor_restore_required 0 - set cursor_saved_attributes "" - set cursor_saved_position "" - # -- --- --- - - #set idx 0 ;# line index (cursor - 1) - #set idx [expr {$opt_colstart + $opt_colcursor} -1] - - #idx is the per column output index - set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1 - #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. - #(for now we are incrementing/decrementing both in sync - which is a bit silly) - set cursor_column $opt_colcursor - - #idx_over is the per grapheme overlay index - set idx_over -1 - - - #movements only occur within the overlay range. - #an underlay is however not necessary.. e.g - #renderline -overflow 1 "" data - #foreach {pt code} $overmap {} - set insert_mode $opt_insert_mode ;#default 1 - set autowrap_mode $opt_autowrap_mode ;#default 1 - - - #puts "-->$overlay_grapheme_control_list<--" - #puts "-->overflow_idx: $overflow_idx" - for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} { - set gc [lindex $overlay_grapheme_control_list $gci] - lassign $gc type item - - #emit plaintext chars first using existing SGR codes from under/over stack as appropriate - #then check if the following code is a cursor movement within the line and adjust index if so - #foreach ch $overlay_graphemes {} - switch -- $type { - g { - set ch $item - incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. - if {($idx < ($opt_colstart -1))} { - incr idx [grapheme_width_cached $ch] - continue - } - #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width - set within_undercols [expr {$idx <= $colwidth-1}] - - #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters - #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, - #on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1. - #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable - #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE - - set chtest [tcl::string::map [list \n \x85 \b \r \v \x7f ] $ch] - #puts --->chtest:$chtest - #specials - each shoud have it's own test of what to do if it happens after overflow_idx reached - switch -- $chtest { - "" { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - if {$idx == 0} { - #puts "---a at col 1" - #linefeed at column 1 - #leave the overflow_idx ;#? review - set instruction lf_start ;#specific instruction for newline at column 1 - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { - #linefeed after final column - #puts "---c at overflow_idx=$overflow_idx" - incr cursor_row - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 - set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } else { - #linefeed occurred in middle or at end of text - #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" - incr cursor_row - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 - set instruction lf_mid - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } - - } - "" { - #will we want/need to use raw for keypresses in terminal? (terminal with LNM in standard reset mode means enter= this is the usual config for terminals) - #So far we are assuming the caller has translated to and handle above.. REVIEW. - - #consider also the old space-carriagereturn softwrap convention used in some terminals. - #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. - set idx [expr {$opt_colstart -1}] - set cursor_column $opt_colstart ;#? - } - "" { - #literal backspace char - not necessarily from keyboard - #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype - #(important for -transparent option - hence replacement chars for half-exposed etc) - #review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR) - if {$idx > ($opt_colstart -1)} { - incr idx -1 - incr cursor_column -1 - } else { - set flag 0 - if $flag { - #review - conflicting requirements? Need a different sequence for destructive interactive backspace? - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction backspace_at_start - break - } - } - } - "" { - #literal del character - some terminals send just this for what is generally expected to be a destructive backspace - #We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect. - priv::render_delchar $idx - } - "" { - #end processing this overline. rest of line is remainder. cursor for column as is. - #REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?) - #e.g it could be configured to jump down 6 rows. - #On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed. - #todo? - incr cursor_row - set overflow_idx $idx - #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction vt - break - } - default { - if {$overflow_idx != -1} { - #review - how to check arbitrary length item such as tab is going to overflow .. before we get to overflow_idx? - #call grapheme_width_cached on each ch, or look for tab specifically as it's currently the only known reason to have a grapheme width > 2? - #we need to decide what a tab spanning the overflow_idx means and how it affects wrap etc etc - if {$idx == $overflow_idx-1} { - set owidth [grapheme_width_cached $ch] - if {$owidth == 2} { - #review split 2w overflow? - #we don't want to make the decision here to split a 2w into replacement characters at end of line and beginning of next line - #better to consider the overlay char as unable to be applied to the line - #render empty column(?) - and reduce overlay grapheme index by one so that the current ch goes into unapplied - #throwing back to caller with instruction complicates its job - but is necessary to avoid making decsions for it here. - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #change the overflow_idx - set overflow_idx $idx - incr idx - incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used - priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci - #throw back to caller's loop - add instruction to caller as this is not the usual case - #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line - set instruction overflow_splitchar - break - } elseif {$owidth > 2} { - #? tab? - #TODO! - puts stderr "overtype::renderline long overtext grapheme '[ansistring VIEW -lf 1 -vt 1 $ch]' not handled" - #tab of some length dependent on tabstops/elastic tabstop settings? - } - } elseif {$idx >= $overflow_idx} { - #jmn? - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] - #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #don't incr idx beyond the overflow_idx - #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied - incr idx_over -1 - #priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too - priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# - set instruction overflow - break - } - } else { - #review. - #This corresponds to opt_overflow being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) - } - - if {($do_transparency && [regexp $opt_transparent $ch])} { - #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) - if {$idx > [llength $outcols]-1} { - lappend outcols " " - #tcl::dict::set understacks $idx [list] ;#review - use idx-1 codestack? - lset understacks $idx [list] - incr idx - incr cursor_column - } else { - #todo - punk::char::char_width - set g [lindex $outcols $idx] - set uwidth [grapheme_width_cached $g] - if {[lindex $outcols $idx] eq ""} { - #2nd col of 2-wide char in underlay - incr idx - incr cursor_column - } elseif {$uwidth == 0} { - #e.g control char ? combining diacritic ? - incr idx - incr cursor_column - } elseif {$uwidth == 1} { - set owidth [grapheme_width_cached $ch] - incr idx - incr cursor_column - if {$owidth > 1} { - incr idx - incr cursor_column - } - } elseif {$uwidth > 1} { - if {[grapheme_width_cached $ch] == 1} { - if {!$insert_mode} { - #normal singlewide transparent overlay onto double-wide underlay - set next_pt_overchar [tcl::string::index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay - if {$next_pt_overchar eq ""} { - #special-case trailing transparent - no next_pt_overchar - incr idx - incr cursor_column - } else { - if {[regexp $opt_transparent $next_pt_overchar]} { - incr idx - incr cursor_column - } else { - #next overlay char is not transparent.. first-half of underlying 2wide char is exposed - #priv::render_addchar $idx $opt_exposed1 [tcl::dict::get $overstacks $idx_over] [tcl::dict::get $overstacks_gx $idx_over] $insert_mode - priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } - } else { - #? todo - decide what transparency even means for insert mode - incr idx - incr cursor_column - } - } else { - #2wide transparency over 2wide in underlay - review - incr idx - incr cursor_column - } - } - } - } else { - - set idxchar [lindex $outcols $idx] - #non-transparent char in overlay or empty cell - if {$idxchar eq "\u0000"} { - #empty/erased cell indicator - set uwidth 1 - } else { - set uwidth [grapheme_width_cached $idxchar] - } - if {$within_undercols} { - if {$idxchar eq ""} { - #2nd col of 2wide char in underlay - if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 - #JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme - #e.g renderline \uFF21\uFF21--- a\uFF23\uFF23 - #vs - # renderline -startcolumn 2 \uFF21---- \uFF23 - if {[lindex $outcols $idx-1] != ""} { - #verified it's an empty following a filled - so it's a legit underlay remnant (REVIEW - when would it not be??) - #reset previous to an exposed 1st-half - but leave understacks code as is - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 - } - incr idx - } else { - set prevcolinfo [lindex $outcols $idx-1] - #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right - #REVIEW - this leaves a replacement character permanently in our columns.. but it is consistent regarding length (?) - #The alternative is to disallow insertion at a column cursor that is at 2nd half of 2wide char - #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises - #It is perhaps best avoided at another level and try to make renderline do exactly as it's told - #the advantage of this 2w splitting method is that the inserted character ends up in exactly the column we expect. - priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 ;#replace not insert - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 1 ;#insert - same index - if {$prevcolinfo ne ""} { - #we've split the 2wide - it may already have been rendered as an exposed1 - but not for example if our startcolumn was current idx - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 ;#replace not insert - } ;# else?? - incr idx - } - if {$cursor_column < [llength $outcols] || $overflow_idx == -1} { - incr cursor_column - } - } elseif {$uwidth == 0} { - #what if this is some other c0/c1 control we haven't handled specifically? - - #by emitting a preceding empty-string column - we associate whatever this char is with the preceeding non-zero-length character and any existing zero-lengths that follow it - #e.g combining diacritic - increment before over char REVIEW - #arguably the previous overchar should have done this - ie lookahead for combiners? - #if we can get a proper grapheme_split function - this should be easier to tidy up. - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column 2 - - if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { - set cursor_column [llength $outcols] - } - } elseif {$uwidth == 1} { - #includes null empty cells - set owidth [grapheme_width_cached $ch] - if {$owidth == 1} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - } else { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #if next column in underlay empty - we've overwritten first half of underlying 2wide grapheme - #replace with rhs exposure in case there are no more overlay graphemes coming - use underlay's stack - if {([llength $outcols] >= $idx +2) && [lindex $outcols $idx+1] eq ""} { - priv::render_addchar [expr {$idx+1}] $opt_exposed2 [lindex $understacks $idx+1] [lindex $understacks_gx $idx+1] $insert_mode - } - incr idx - } - if {($cursor_column < [llength $outcols]) || $overflow_idx == -1 || $test_mode} { - incr cursor_column - } - } elseif {$uwidth > 1} { - set owidth [grapheme_width_cached $ch] - if {$owidth == 1} { - #1wide over 2wide in underlay - if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char - } else { - #insert mode just pushes all to right - no exposition char here - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } else { - #2wide over 2wide - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx 2 - incr cursor_column 2 - } - - if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { - set cursor_column [llength $outcols] - } - } - } else { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - if {$overflow_idx !=-1 && !$test_mode} { - #overflow - if {$cursor_column > [llength $outcols]} { - set cursor_column [llength $outcols] - } - } - } - } - } - } ;# end switch - - - } - other { - set code $item - #since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied' - - set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM - set re_col_move {\x1b\[([0-9]*)(C|D|G)$} - set re_row_move {\x1b\[([0-9]*)(A|B)$} - set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? - set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} - set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)! - set re_cursor_restore {\x1b\[u$} - set re_cursor_save_dec {\x1b7$} - set re_cursor_restore_dec {\x1b8$} - set re_other_single {\x1b(D|M|E)$} - set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins - set matchinfo [list] - - #remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI - #probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping - #review - cost/benefit of function calls within these switch-arms instead of inline code? - - #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. - #we should probably therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore - set code [tcl::string::map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $code] - - - set c1 [tcl::string::index $code 0] - set c1c2c3 [tcl::string::range $code 0 2] - #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[< 1006\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\] 7OSC\ - \x9d 8OSC\ - \x1b 7ESC\ - ] $c1c2c3] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars - - #we leave the tail of the code unmapped for now - switch -- $leadernorm { - 1006 { - #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html - #SGR (1006) CSI < followed by colon separated encoded-button-value,px,py ordinates and final M for button press m for button release - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] - } - 7CSI - 7OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] - } - 7ESC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - 8CSI - 8OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - default { - #we haven't made a mapping for this - set codenorm $code - } - } - - #we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables. - switch -- $leadernorm { - 1006 { - #TODO - # - switch -- [tcl::string::index $codenorm end] { - M { - puts stderr "mousedown $codenorm" - } - m { - puts stderr "mouseup $codenorm" - } - } - - } - {7CSI} - {8CSI} { - set param [tcl::string::range $codenorm 4 end-1] - #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" - switch -- [tcl::string::index $codenorm end] { - D { - #Col move - #puts stdout "<-back" - #cursor back - #left-arrow/move-back when ltr mode - set num $param - if {$num eq ""} {set num 1} - - set version 2 - if {$version eq "2"} { - #todo - startcolumn offset! - if {$cursor_column - $num >= 1} { - incr idx -$num - incr cursor_column -$num - } else { - if {!$autowrap_mode} { - set cursor_column 1 - set idx 0 - } else { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr cursor_column -$num - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction wrapmovebackward - break - } - } - } else { - incr idx -$num - incr cursor_column -$num - if {$idx < $opt_colstart-1} { - #wrap to previous line and position cursor at end of data - set idx [expr {$opt_colstart-1}] - set cursor_column $opt_colstart - } - } - } - C { - #Col move - #puts stdout "->forward" - #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. - #cursor forward - #right-arrow/move forward - set num $param - if {$num eq ""} {set num 1} - - #todo - retrict to moving 1 position past datalen? restrict to column width? - #should ideally wrap to next line when interactive and not on last row - #(some ansi art seems to expect this behaviour) - #This presumably depends on the terminal's wrap mode - #e.g DECAWM autowrap mode - # CSI ? 7 h - set: autowrap (also tput smam) - # CSI ? 7 l - reset: no autowrap (also tput rmam) - set version 2 - if {$version eq "2"} { - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$test_mode && $cursor_column == $max+1} { - #move_forward while in overflow - incr cursor_column -1 - } - - if {($cursor_column + $num) <= $max} { - incr idx $num - incr cursor_column $num - } else { - if {$autowrap_mode} { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #jmn - if {$idx == $overflow_idx} { - incr num - } - - #horizontal movement beyond line extent needs to wrap - throw back to caller - #we may have both overflow_rightand unapplied data - #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) - #leave row as is - caller will need to determine how many rows the column-movement has consumed - incr cursor_column $num ;#give our caller the necessary info as columns from start of row - #incr idx_over - #should be gci following last one applied - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction wrapmoveforward - break - } else { - set cursor_column $max - set idx [expr {$cursor_column -1}] - } - } - } else { - if {!$opt_overflow || ($cursor_column + $num) <= [llength $outcols+1]} { - incr idx $num - incr cursor_column $num - } else { - if {!$insert_mode} { - #block editing style with arrow keys - #overtype mode - set idxstart $idx - set idxend [llength $outcols] - set moveend [expr {$idxend - $idxstart}] - if {$moveend < 0} {set moveend 0} ;#sanity? - #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" - incr idx $moveend - incr cursor_column $moveend - #if {[tcl::dict::exists $understacks $idx]} { - # set stackinfo [tcl::dict::get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext - #} else { - # set stackinfo [list] - #} - if {$idx < [llength $understacks]} { - set stackinfo [lindex $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext - } else { - set stackinfo [list] - } - if {$idx < [llength $understacks_gx]} { - #set gxstackinfo [tcl::dict::get $understacks_gx $idx] - set gxstackinfo [lindex $understacks_gx $idx] - } else { - set gxstackinfo [list] - } - #pad outcols - set movemore [expr {$num - $moveend}] - #assert movemore always at least 1 or we wouldn't be in this branch - for {set m 1} {$m <= $movemore} {incr m} { - incr idx - incr cursor_column - priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode - } - } else { - #normal - insert - incr idx $num - incr cursor_column $num - if {$idx > [llength $outcols]} { - set idx [llength $outcols];#allow one beyond - for adding character at end of line - set cursor_column [expr {[llength $outcols]+1}] - } - } - } - } - } - G { - #Col move - #move absolute column - #adjust to colstart - as column 1 is within overlay - #??? - set idx [expr {$param + $opt_colstart -1}] - set cursor_column $param - error "renderline absolute col move ESC G unimplemented" - } - A { - #Row move - up - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set num $param - if {$num eq ""} {set num 1} - incr cursor_row -$num - - if {$cursor_row < 1} { - set cursor_row 1 - } - - #ensure rest of *overlay* is emitted to remainder - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction up - #retain cursor_column - break - } - B { - #Row move - down - set num $param - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move down - if {$num eq ""} {set num 1} - incr cursor_row $num - - - incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction down - #retain cursor_column - break - } - H - f { - #$re_both_move - lassign [split $param {;}] row col - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #lassign $matchinfo _match row col - - if {$col eq ""} {set col 1} - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$col > $max} { - set cursor_column $max - } else { - set cursor_column $col - } - set idx [expr {$cursor_column -1}] - - if {$row eq ""} {set row 1} - set cursor_row $row - if {$cursor_row < 1} { - set cursor_row 1 - } - - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - - } - X { - puts stderr "X - $param" - #ECH - erase character - if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase - priv::render_erasechar $idx $param - #cursor position doesn't change. - } - r { - #$re_decstbm - #https://www.vt100.net/docs/vt510-rm/DECSTBM.html - #This control function sets the top and bottom margins for the current page. You cannot perform scrolling outside the margins - lassign [split $param {;}] margin_top margin_bottom - - #todo - return these for the caller to process.. - puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" - #Also moves the cursor to col 1 line 1 of the page - set cursor_column 1 - set cursor_row 1 - - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move ;#own instruction? decstbm? - break - } - s { - # - todo - make ansi.sys CSI s cursor save only apply for certain cases? - may need to support DECSLRM instead which uses same code - - #$re_cursor_save - #cursor save could come after last column - if {$overflow_idx != -1 && $idx == $overflow_idx} { - #bartman2.ans test file - fixes misalignment at bottom of dialog bubble - #incr cursor_row - #set cursor_column 1 - #bwings1.ans test file - breaks if we actually incr cursor (has repeated saves) - set cursor_saved_position [list row [expr {$cursor_row+1}] column 1] - } else { - set cursor_saved_position [list row $cursor_row column $cursor_column] - } - #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. - #we need the SGR and gx overlay codes prior to the cursor_save - - #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. - #set sgr_stack [lindex $understacks $idx] - #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) - - set sgr_stack [list] - set gx_stack [list] - - #we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those. - #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. - - foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { - lassign $gc type code - #types g other sgr gx0 - switch -- $type { - gx0 { - #code is actually a stand-in for the graphics on/off code - not the raw code - #It is either gx0_on or gx0_off - set gx_stack [list $code] - } - sgr { - #code is the raw code - if {[punk::ansi::codetype::is_sgr_reset $code]} { - #jmn - set sgr_stack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set sgr_stack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #often we don't get resets - and codes just pile up. - #as a first step to simplifying - at least remove earlier straight up dupes - set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars) - set sgr_stack [lremove $sgr_stack {*}$dup_posns] - lappend sgr_stack $code - } - } - } - } - set cursor_saved_attributes "" - switch -- [lindex $gx_stack 0] { - gx0_on { - append cursor_saved_attributes "\x1b(0" - } - gx0_off { - append cursor_saved_attributes "\x1b(B" - } - } - #append cursor_saved_attributes [join $sgr_stack ""] - append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack] - - #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. - - #don't incr index - or the save will cause cursor to move to the right - #carry on - - } - u { - #$re_cursor_restore - #we are going to jump somewhere.. for now we will assume another line, and process accordingly. - #The caller has the cursor_saved_position/cursor_saved_attributes if any (?review - if we always pass it back it, we could save some calls for moves in same line) - #don't set overflow at this point. The existing underlay to the right must be preserved. - #we only want to jump and render the unapplied at the new location. - - #lset overstacks $idx_over [list] - #set replay_codes_overlay "" - - #if {$cursor_saved_attributes ne ""} { - # set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk - #} else { - #jj - #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set replay_codes_overlay "" - #} - - #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code - incr idx_over - - set unapplied "" - set unapplied_list [list] - foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { - lassign $gc type item - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - #incr idx_over - } - set unapplied [join $unapplied_list ""] - #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. - set instruction restore_cursor - break - } - ~ { - #$re_vt_sequence - #lassign $matchinfo _match key mod - lassign [split $param {;}] key mod - - #Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~ - # - #e.g esc \[2~ insert esc \[2;2~ shift-insert - #mod - subtract 1, and then use bitmask - #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) - #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" - if {$key eq "1"} { - #home - } elseif {$key eq "2"} { - #Insert - if {$mod eq ""} { - #no modifier key - set insert_mode [expr {!$insert_mode}] - #rather than set the cursor - we return the insert mode state so the caller can decide - } - } elseif {$key eq "3"} { - #Delete - presumably this shifts other chars in the line, with empty cells coming in from the end - switch -- $mod { - "" { - priv::render_delchar $idx - } - "5" { - #ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?) - } - } - } elseif {$key eq "4"} { - #End - } elseif {$key eq "5"} { - #pgup - } elseif {$key eq "6"} { - #pgDn - } elseif {$key eq "7"} { - #Home - #?? - set idx [expr {$opt_colstart -1}] - set cursor_column 1 - } elseif {$key eq "8"} { - #End - } elseif {$key eq "11"} { - #F1 - or ESCOP or e.g shift F1 ESC\[1;2P - } elseif {$key eq "12"} { - #F2 - or ESCOQ - } elseif {$key eq "13"} { - #F3 - or ESCOR - } elseif {$key eq "14"} { - #F4 - or ESCOS - } elseif {$key eq "15"} { - #F5 or shift F5 ESC\[15;2~ - } elseif {$key eq "17"} { - #F6 - } elseif {$key eq "18"} { - #F7 - } elseif {$key eq "19"} { - #F8 - } elseif {$key eq "20"} { - #F9 - } elseif {$key eq "21"} { - #F10 - } elseif {$key eq "23"} { - #F11 - } elseif {$key eq "24"} { - #F12 - } - - } - h - l { - #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? - - #$re_mode if first after CSI is "?" - #some docs mention ESC=h|l - not seen on windows terminals.. review - #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html - if {[tcl::string::index $codenorm 4] eq "?"} { - set num [tcl::string::range $codenorm 5 end-1] ;#param between ? and h|l - #lassign $matchinfo _match num type - switch -- $num { - 5 { - #DECSNM - reverse video - #How we simulate this to render within a block of text is an open question. - #track all SGR stacks and constantly flip based on the current SGR reverse state? - #It is the job of the calling loop to do this - so at this stage we'll just set the states - #DECAWM autowrap - if {$type eq "h"} { - #set (enable) - set reverse_mode 1 - } else { - #reset (disable) - set reverse_mode 0 - } - - } - 7 { - #DECAWM autowrap - if {$type eq "h"} { - #set (enable) - set autowrap_mode 1 - if {$opt_width ne "\uFFEF"} { - set overflow_idx $opt_width - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? presume not - but sanity check for now. - if {$idx >= $overflow_idx} { - puts stderr "renderline error - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" - } - } else { - #reset (disable) - set autowrap_mode 0 - set overflow_idx -1 - } - } - 25 { - if {$type eq "h"} { - #visible cursor - - } else { - #invisible cursor - - } - } - } - - } else { - puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - default { - puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - } - 7ESC { - #$re_other_single - switch -- [tcl::string::index $codenorm end] { - D { - #\x84 - #index (IND) - #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" - puts stderr "ESC D not fully implemented" - incr cursor_row - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction down - #retain cursor_column - break - } - M { - #\x8D - #Reverse Index (RI) - #vt102-docs: "Moves cursor up one line in same column. If cursor is at top margin, screen performs a scroll-down" - puts stderr "ESC M not fully implemented" - - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move up - incr cursor_row -1 - if {$cursor_row < 1} { - set cursor_row 1 - } - #ensure rest of *overlay* is emitted to remainder - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction up ;#need instruction for scroll-down? - #retain cursor_column - break - } - E { - #\x85 - #review - is behaviour different to lf? - #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL - #leave implementation until logic for is set in stone... still under review - #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. - # - #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" - puts stderr "ESC E unimplemented" - - } - default { - puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - - } - } - - #switch -regexp -matchvar matchinfo -- $code\ - #$re_mode { - #}\ - #default { - # puts stderr "overtype::renderline code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - #} - - } - default { - #don't need to handle sgr or gx0 types - #we have our sgr gx0 codes already in stacks for each overlay grapheme - } - } - } - - #-------- - if {$opt_overflow == 0} { - #need to truncate to the width of the original undertext - #review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? - #set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars - } - if {$overflow_idx == -1} { - #overflow was initially unlimited and hasn't been overridden - } else { - - } - #-------- - - - #coalesce and replay codestacks for outcols grapheme list - set outstring "" ;#output prior to overflow - set overflow_right "" ;#remainder after overflow point reached - set i 0 - set cstack [list] - set prevstack [list] - set prev_g0 [list] - #note overflow_idx may already have been set lower if we had a row move above due to \v or ANSI moves - set in_overflow 0 ;#used to stop char-width scanning once in overflow - if {$overflow_idx == 0} { - #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW - set in_overflow 1 - } - foreach ch $outcols { - #puts "---- [ansistring VIEW $ch]" - - set gxleader "" - if {$i < [llength $understacks_gx]} { - #set g0 [tcl::dict::get $understacks_gx $i] - set g0 [lindex $understacks_gx $i] - if {$g0 ne $prev_g0} { - if {$g0 eq [list "gx0_on"]} { - set gxleader "\x1b(0" - } else { - set gxleader "\x1b(B" - } - } - set prev_g0 $g0 - } else { - set prev_g0 [list] - } - - set sgrleader "" - if {$i < [llength $understacks]} { - #set cstack [tcl::dict::get $understacks $i] - set cstack [lindex $understacks $i] - if {$cstack ne $prevstack} { - if {[llength $prevstack] && ![llength $cstack]} { - #This reset is important e.g testfile fruit.ans - we get overhang on rhs without it. But why is cstack empty? - append sgrleader \033\[m - } else { - append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] - } - } - set prevstack $cstack - } else { - set prevstack [list] - } - - - - if {$in_overflow} { - if {$i == $overflow_idx} { - set 0 [lindex $understacks_gx $i] - set gxleader "" - if {$g0 eq [list "gx0_on"]} { - set gxleader "\x1b(0" - } elseif {$g0 eq [list "gx0_off"]} { - set gxleader "\x1b(B" - } - append overflow_right $gxleader - set cstack [lindex $understacks $i] - set sgrleader "" - #whether cstack is same or differs from previous char's stack - we must have an output at the start of the overflow_right - #if {[llength $prevstack] && ![llength $cstack]} { - # append sgrleader \033\[m - #} - append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] - append overflow_right $sgrleader - append overflow_right $ch - } else { - append overflow_right $gxleader - append overflow_right $sgrleader - append overflow_right $ch - } - } else { - if {$overflow_idx != -1 && $i+1 == $overflow_idx} { - #one before overflow - #will be in overflow in next iteration - set in_overflow 1 - if {[grapheme_width_cached $ch]> 1} { - #we overflowed with second-half of a double-width char - replace first-half with user-supplied exposition char (should be 1 wide) - set ch $opt_exposed1 - } - } - append outstring $gxleader - append outstring $sgrleader - if {$idx+1 < $cursor_column} { - append outstring [tcl::string::map {\u0000 " "} $ch] - } else { - append outstring $ch - } - } - incr i - } - #flower.ans good test for null handling - reverse line building - if {![ansistring length $overflow_right]} { - set outstring [tcl::string::trimright $outstring "\u0000"] - } - set outstring [tcl::string::map {\u0000 " "} $outstring] - set overflow_right [tcl::string::trimright $overflow_right "\u0000"] - set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] - - set replay_codes "" - if {[llength $understacks] > 0} { - if {$overflow_idx == -1} { - #set tail_idx [tcl::dict::size $understacks] - set tail_idx [llength $understacks] - } else { - set tail_idx [llength $undercols] - } - if {$tail_idx-1 < [llength $understacks]} { - #set replay_codes [join [lindex $understacks $tail_idx-1] ""] ;#tail replay codes - set replay_codes [punk::ansi::codetype::sgr_merge_list {*}[lindex $understacks $tail_idx-1]] ;#tail replay codes - } - if {$tail_idx-1 < [llength $understacks_gx]} { - set gx0 [lindex $understacks_gx $tail_idx-1] - if {$gx0 eq [list "gx0_on"]} { - #if it was on, turn gx0 off at the point we stop processing overlay - append outstring "\x1b(B" - } - } - } - if {[string length $overflow_right]} { - #puts stderr "remainder:$overflow_right" - } - #pdict $understacks - - if {[punk::ansi::ta::detect_sgr $outstring]} { - append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column - - #close off any open gx? - #probably should - and overflow_right reopen? - } - - if {$opt_returnextra} { - #replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review - #replay_codes_underlay is the set of codes in effect at the very end of the original underlay - - #review - #replay_codes_overlay is the set of codes in effect at the very end of the original overlay (even if not all overlay was applied) - #todo - replay_codes for gx0 mode - - #overflow_idx may change during ansi & character processing - if {$overflow_idx == -1} { - set overflow_right_column "" - } else { - set overflow_right_column [expr {$overflow_idx+1}] - } - set result [tcl::dict::create\ - result $outstring\ - visualwidth [punk::ansi::printing_length $outstring]\ - instruction $instruction\ - stringlen [string length $outstring]\ - overflow_right_column $overflow_right_column\ - overflow_right $overflow_right\ - unapplied $unapplied\ - unapplied_list $unapplied_list\ - insert_mode $insert_mode\ - autowrap_mode $autowrap_mode\ - insert_lines_above $insert_lines_above\ - insert_lines_below $insert_lines_below\ - cursor_saved_position $cursor_saved_position\ - cursor_saved_attributes $cursor_saved_attributes\ - cursor_column $cursor_column\ - cursor_row $cursor_row\ - opt_overflow $opt_overflow\ - replay_codes $replay_codes\ - replay_codes_underlay $replay_codes_underlay\ - replay_codes_overlay $replay_codes_overlay\ - ] - if {$opt_returnextra == 1} { - return $result - } else { - #human/debug - map special chars to visual glyphs - set viewop VIEW - switch -- $opt_returnextra { - 2 { - #codes and character data - set viewop VIEWCODES ;#ansi colorisation of codes - green for SGR, blue/blue reverse for cursor_save/cursor_restore, cyan for movements, orange for others - } - 3 { - set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. - } - } - tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] - tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] - tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]] - tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] - tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] - tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] - tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] - tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] - return $result - } - } else { - return $outstring - } - #return [join $out ""] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace overtype ---}] -} - -tcl::namespace::eval overtype::piper { - proc overcentre {args} { - if {[llength $args] < 2} { - error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} - } - lassign [lrange $args end-1 end] over under - set argsflags [lrange $args 0 end-2] - tailcall overtype::centre {*}$argsflags $under $over - } - proc overleft {args} { - if {[llength $args] < 2} { - error {usage: ?-startcolumn ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} - } - lassign [lrange $args end-1 end] over under - set argsflags [lrange $args 0 end-2] - tailcall overtype::left {*}$argsflags $under $over - } -} - - -# -- --- --- --- --- --- --- --- --- --- --- -proc overtype::transparentline {args} { - foreach {under over} [lrange $args end-1 end] break - set argsflags [lrange $args 0 end-2] - set defaults [tcl::dict::create\ - -transparent 1\ - -exposed 1 " "\ - -exposed 2 " "\ - ] - set newargs [tcl::dict::merge $defaults $argsflags] - tailcall overtype::renderline {*}$newargs $under $over -} -#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. -# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. -#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. -# -tcl::namespace::eval overtype::piper { - proc renderline {args} { - if {[llength $args] < 2} { - error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? overtext pipelinedata} - } - foreach {over under} [lrange $args end-1 end] break - set argsflags [lrange $args 0 end-2] - tailcall overtype::renderline {*}$argsflags $under $over - } -} -interp alias "" piper_renderline "" overtype::piper::renderline - -#intended for single grapheme - but will work for multiple -#cannot contain ansi or newlines -#(a cache of ansifreestring_width calls - as these are quite regex heavy) -proc overtype::grapheme_width_cached {ch} { - variable grapheme_widths - if {[tcl::dict::exists $grapheme_widths $ch]} { - return [tcl::dict::get $grapheme_widths $ch] - } - set width [punk::char::ansifreestring_width $ch] - tcl::dict::set grapheme_widths $ch $width - return $width -} - - - -proc overtype::test_renderline {} { - set t \uFF5E ;#2-wide tilde - set u \uFF3F ;#2-wide underscore - set missing \uFFFD - return [list $t $u A${t}B] -} - -#maintenance warning -#same as textblock::size - but we don't want that circular dependency -#block width and height can be tricky. e.g \v handled differently on different terminal emulators and can affect both -proc overtype::blocksize {textblock} { - if {$textblock eq ""} { - return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings - } - if {[string first \t $textblock] >= 0} { - if {[info exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - #stripansi on entire block in one go rather than line by line - result should be the same - review - make tests - if {[punk::ansi::ta::detect $textblock]} { - set textblock [punk::ansi::stripansi $textblock] - } - if {[string first \n $textblock] >= 0} { - set num_le [expr {[string length $textblock]-[string length [tcl::string::map {\n {}} $textblock]]}] ;#faster than splitting into single-char list - set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } else { - set num_le 0 - set width [punk::char::ansifreestring_width $textblock] - } - #our concept of block-height is likely to be different to other line-counting mechanisms - set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - - return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize ]] width height -} - -tcl::namespace::eval overtype::priv { - variable cache_is_sgr [tcl::dict::create] - - #we are likely to be asking the same question of the same ansi codes repeatedly - #caching the answer saves some regex expense - possibly a few uS to lookup vs under 1uS - #todo - test if still worthwhile after a large cache is built up. (limit cache size?) - proc is_sgr {code} { - variable cache_is_sgr - if {[tcl::dict::exists $cache_is_sgr $code]} { - return [tcl::dict::get $cache_is_sgr $code] - } - set answer [punk::ansi::codetype::is_sgr $code] - tcl::dict::set cache_is_sgr $code $answer - return $answer - } - proc render_unapplied {overlay_grapheme_control_list gci} { - upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split - upvar overstacks overstacks - upvar overstacks_gx overstacks_gx - upvar overlay_grapheme_control_stacks og_stacks - - #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] - #append unapplied [join [lindex $overstacks $idx_over] ""] - #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] - set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] - if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged - } - switch -- [lindex $overstacks_gx $idx_over] { - "gx0_on" { - lappend unapplied_list "\x1b(0" - } - "gx0_off" { - lappend unapplied_list "\x1b(B" - } - } - - foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { - lassign $gc type item - #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - } - set unapplied [join $unapplied_list ""] - } - - #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack - proc render_this_unapplied {overlay_grapheme_control_list gci} { - upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list - upvar overstacks overstacks - upvar overstacks_gx overstacks_gx - upvar overlay_grapheme_control_stacks og_stacks - - #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] - - set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] - if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged - } - switch -- [lindex $overstacks_gx $idx_over] { - "gx0_on" { - lappend unapplied_list "\x1b(0" - } - "gx0_off" { - lappend unapplied_list "\x1b(B" - } - } - - foreach gc [lrange $overlay_grapheme_control_list $gci end] { - lassign $gc type item - #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - } - set unapplied [join $unapplied_list ""] - } - proc render_delchar {i} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - set nxt [llength $o] - if {$i < $nxt} { - set o [lreplace $o $i $i] - set ustacks [lreplace $ustacks $i $i] - set gxstacks [lreplace $gxstacks $i $i] - } else { - - } - } - proc render_erasechar {i count} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - #ECH clears character attributes from erased character positions - #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller should do that mapping and only supply 1 or greater. - if {![tcl::string::is integer -strict $count] || $count < 1} { - error "render_erasechar count must be integer >= 1" - } - set start $i - set end [expr {$i + $count -1}] - #we restrict ECH to current line - as some terminals do - review - is that the only way it's implemented? - if {$i > [llength $o]-1} { - return - } - if {$end > [llength $o]-1} { - set end [expr {[llength $o]-1}] - } - set num [expr {$end - $start + 1}] - set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space? - set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list]]] - set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] - return - } - proc render_setchar {i c } { - upvar outcols o - lset o $i $c - } - #is actually addgrapheme? - proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - - if 0 { - if {$c eq "c"} { - puts "i:$i c:$c sgrstack:[ansistring VIEW $sgrstack]" - puts "understacks:[ansistring VIEW $ustacks]" - upvar overstacks overstacks - puts "overstacks:[ansistring VIEW $overstacks]" - puts "info level 0:[info level 0]" - } - } - - set nxt [llength $o] - if {!$insert_mode} { - if {$i < $nxt} { - #These lists must always be in sync - lset o $i $c - } else { - lappend o $c - } - if {$i < [llength $ustacks]} { - lset ustacks $i $sgrstack - lset gxstacks $i $gx0stack - } else { - lappend ustacks $sgrstack - lappend gxstacks $gx0stack - } - } else { - #insert of single-width vs double-width when underlying is double-width? - if {$i < $nxt} { - set o [linsert $o $i $c] - } else { - lappend o $c - } - if {$i < [llength $ustacks]} { - set ustacks [linsert $ustacks $i $sgrstack] - set gxstacks [linsert $gxstacks $i $gx0stack] - } else { - lappend ustacks $sgrstack - lappend gxstacks $gx0stack - } - } - } - -} - - - -# -- --- --- --- --- --- --- --- --- --- --- -tcl::namespace::eval overtype { - interp alias {} ::overtype::center {} ::overtype::centre -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide overtype [tcl::namespace::eval overtype { - variable version - set version 1.6.3 -}] -return - -#*** !doctools -#[manpage_end] diff --git a/src/vendormodules/overtype-1.6.4.tm b/src/vendormodules/overtype-1.6.4.tm deleted file mode 100644 index 42876322..00000000 --- a/src/vendormodules/overtype-1.6.4.tm +++ /dev/null @@ -1,3685 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) Julian Noble 2003-2023 -# -# @@ Meta Begin -# Application overtype 1.6.4 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin overtype_module_overtype 0 1.6.4] -#[copyright "2024"] -#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] -#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] -#[require overtype] -#[keywords module text ansi] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of overtype -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by overtype -#[list_begin itemized] - -package require Tcl 8.6- -package require textutil -package require punk::lib ;#required for lines_as_list -package require punk::ansi ;#required to detect, split, strip and calculate lengths -package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars -package require punk::assertion -#*** !doctools -#[item] [package {Tcl 8.6}] -#[item] [package textutil] -#[item] [package punk::ansi] -#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes -#[item] [package punk::char] -#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -#PERFORMANCE notes -#overtype is very performance sensitive - used in ansi output all over the place ie needs to be optimised -#NOTE use of tcl::dict::for tcl::string::range etc instead of ensemble versions. This is for the many tcl 8.6/8.7 interps which don't compile ensemble commands when in safe interps -#similar for tcl::namespace::eval - but this is at least on some versions of Tcl - faster even in a normal interp. Review to see if that holds for Tcl 9. -#for string map: when there are exactly 2 elements - it is faster to use a literal which has a special case optimisation in the c code -#ie use tcl::string::map {\n ""} ... instead of tcl::string::map [list \n ""] ... -#note that we can use unicode (e.g \uFF31) and other escapes such as \t within these curly braces - we don't have to use double quotes -#generally using 'list' is preferred for the map as less error prone. -#can also use: tcl::string::map "token $var" .. but be careful regarding quoting and whitespace in var. This should be used sparingly if at all. - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section API] - - -#Julian Noble - 2003 -#Released under standard 'BSD license' conditions. -# -#todo - ellipsis truncation indicator for center,right - -#v1.4 2023-07 - naive ansi color handling - todo - fix tcl::string::range -# - need to extract and replace ansi codes? - -tcl::namespace::eval overtype { - namespace import ::punk::assertion::assert - punk::assertion::active true - - namespace path ::punk::lib - - namespace export * - variable default_ellipsis_horizontal "..." ;#fallback - variable default_ellipsis_vertical "..." - tcl::namespace::eval priv { - proc _init {} { - upvar ::overtype::default_ellipsis_horizontal e_h - upvar ::overtype::default_ellipsis_vertical e_v - set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis - set e_v [format %c 0x22EE] - #The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text - #Also - unicode ellipsis has semantic meaning that other processors can interpret - #unicode does also provide a midline horizontal ellipsis 0x22EF - - #set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal - #if {![catch {package require punk::char}]} { - # set e [punk::char::charshort boxd_ltdshhz] - #} - } - } - priv::_init -} -proc overtype::about {} { - return "Simple text formatting. Author JMN. BSD-License" -} - -tcl::namespace::eval overtype { - variable grapheme_widths [tcl::dict::create] - - variable escape_terminals - #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - tcl::dict::set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] - #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - tcl::dict::set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals - - #self-contained 2 byte ansi escape sequences - review more? - variable ansi_2byte_codes_dict - set ansi_2byte_codes_dict [tcl::dict::create\ - "reset_terminal" "\u001bc"\ - "save_cursor_posn" "\u001b7"\ - "restore_cursor_posn" "\u001b8"\ - "cursor_up_one" "\u001bM"\ - "NEL - Next Line" "\u001bE"\ - "IND - Down one line" "\u001bD"\ - "HTS - Set Tab Stop" "\u001bH"\ - ] - - #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. - # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ -} - - -#proc overtype::stripansi {text} { -# variable escape_terminals ;#dict -# variable ansi_2byte_codes_dict -# #important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway -# if {[string first \033 $text] <0 && [string first \009c $text] <0} { -# #\033 same as \x1b -# return $text -# } -# -# set text [convert_g0 $text] -# -# #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. -# #line endings can theoretically occur within an ansi escape sequence (review e.g title?) -# set inputlist [split $text ""] -# set outputlist [list] -# -# set 2bytecodes [dict values $ansi_2byte_codes_dict] -# -# set in_escapesequence 0 -# #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls -# set i 0 -# foreach u $inputlist { -# set v [lindex $inputlist $i+1] -# set uv ${u}${v} -# if {$in_escapesequence eq "2b"} { -# #2nd byte - done. -# set in_escapesequence 0 -# } elseif {$in_escapesequence != 0} { -# set escseq [tcl::dict::get $escape_terminals $in_escapesequence] -# if {$u in $escseq} { -# set in_escapesequence 0 -# } elseif {$uv in $escseq} { -# set in_escapseequence 2b ;#flag next byte as last in sequence -# } -# } else { -# #handle both 7-bit and 8-bit CSI and OSC -# if {[regexp {^(?:\033\[|\u009b)} $uv]} { -# set in_escapesequence CSI -# } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { -# set in_escapesequence OSC -# } elseif {$uv in $2bytecodes} { -# #self-contained e.g terminal reset - don't pass through. -# set in_escapesequence 2b -# } else { -# lappend outputlist $u -# } -# } -# incr i -# } -# return [join $outputlist ""] -#} - - - - - -proc overtype::string_columns {text} { - if {[punk::ansi::ta::detect $text]} { - #error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::stripansi. Alternatively try punk::ansi::printing_length" - set text [punk::ansi::stripansi $text] - } - return [punk::char::ansifreestring_width $text] -} - -#todo - consider a way to merge overtype::left/centre/right -#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock -#overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay. -#(i.e not even necessariy having it's top left within the underlay) -tcl::namespace::eval overtype::priv { -} - -#could return larger than colwidth -proc _get_row_append_column {row} { - upvar outputlines outputlines - set idx [expr {$row -1}] - if {$row <= 1 || $row > [llength $outputlines]} { - return 1 - } else { - upvar opt_overflow opt_overflow - upvar colwidth colwidth - set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] - set endpos [expr {$existinglen +1}] - if {$opt_overflow} { - return $endpos - } else { - if {$endpos > $colwidth} { - return $colwidth + 1 - } else { - return $endpos - } - } - } -} - -tcl::namespace::eval overtype { - #*** !doctools - #[subsection {Namespace overtype}] - #[para] Core API functions for overtype - #[list_begin definitions] - - - - #tcl::string::range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r - #render onto an already-rendered (ansi already processed) 'underlay' string, a possibly ansi-laden 'overlay' string. - #The underlay and overlay can be multiline blocks of text of varying line lengths. - #The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. - #This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call. - # a cursor start position other than top-left is a possible addition to consider. - #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline - proc renderspace {args} { - #*** !doctools - #[call [fun overtype::renderspace] [arg args] ] - #[para] usage: ?-transparent [lb]0|1[rb]? ?-overflow [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext - - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext - variable default_ellipsis_horizontal - - if {[llength $args] < 2} { - error {usage: ?-transparent [0|1]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - lassign [lrange $args end-1 end] underblock overblock - set opts [tcl::dict::create\ - -bias ignored\ - -width \uFFEF\ - -height \uFFEF\ - -startcolumn 1\ - -wrap 0\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -appendlines 1\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -experimental 0\ - -looplimit \uFFEF\ - ] - #-ellipsis args not used if -wrap is true - set argsflags [lrange $args 0 end-2] - foreach {k v} $argsflags { - switch -- $k { - -looplimit - -width - -height - -startcolumn - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -appendlines - -transparent - -exposed1 - -exposed2 - -experimental { - tcl::dict::set opts $k $v - } - default { - error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_overflow [tcl::dict::get $opts -overflow] - ##### - # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. - set opt_wrap [tcl::dict::get $opts -wrap] ;#wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) - ##### - #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. - set opt_width [tcl::dict::get $opts -width] - set opt_height [tcl::dict::get $opts -height] - set opt_startcolumn [tcl::dict::get $opts -startcolumn] - set opt_appendlines [tcl::dict::get $opts -appendlines] - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_exposed1 [tcl::dict::get $opts -exposed1] ;#widechar_exposed_left - todo - set opt_exposed2 [tcl::dict::get $opts -exposed2] ;#widechar_exposed_right - todo - # -- --- --- --- --- --- - - # ---------------------------- - # -experimental dev flag to set flags etc - # ---------------------------- - set data_mode 0 - set test_mode 1 - set info_mode 0 - set edit_mode 0 - set opt_experimental [tcl::dict::get $opts -experimental] - foreach o $opt_experimental { - switch -- $o { - test_mode { - set test_mode 1 - set info_mode 1 - } - old_mode { - set test_mode 0 - set info_mode 1 - } - data_mode { - set data_mode 1 - } - info_mode { - set info_mode 1 - } - edit_mode { - set edit_mode 1 - } - } - } - set test_mode 1 ;#try to eliminate - # ---------------------------- - - #modes - set insert_mode 0 ;#can be toggled by insert key or ansi IRM sequence ESC [ 4 h|l - set autowrap_mode $opt_wrap - set reverse_mode 0 - - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - - #set underlines [split $underblock \n] - - #underblock is a 'rendered' block - so width height make sense - #colwidth & colheight were originally named with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. - #The naming is now confusing. It should be something like renderwidth renderheight ?? review - - if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { - lassign [blocksize $underblock] _w colwidth _h colheight - if {$opt_width ne "\uFFEF"} { - set colwidth $opt_width - } - if {$opt_height ne "\uFFEF"} { - set colheight $opt_height - } - } else { - set colwidth $opt_width - set colheight $opt_height - } - - # -- --- --- --- - #REVIEW - do we need ansi resets in the underblock? - if {$underblock eq ""} { - set underlines [lrepeat $colheight ""] - } else { - set underlines [split $underblock \n] - } - #if {$underblock eq ""} { - # set blank "\x1b\[0m\x1b\[0m" - # #set underlines [list "\x1b\[0m\x1b\[0m"] - # set underlines [lrepeat $colheight $blank] - #} else { - # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW - # set underlines [lines_as_list -ansiresets 1 $underblock] - #} - # -- --- --- --- - - #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. - #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output colwidth - #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. - #(in cases where there are interline moves or cursor jumps anyway) - #This works - but doesn't seem efficient. - #On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first - - #a hack until we work out how to avoid infinite loops... - # - set looplimit [tcl::dict::get $opts -looplimit] - if {$looplimit eq "\uFFEF"} { - #looping for each char is worst case (all newlines?) - anything over that is an indication of something broken? - #do we need any margin above the length? (telnet mapscii.me test) - set looplimit [expr {[tcl::string::length $overblock] + 10}] - } - - if {!$test_mode} { - set inputchunks [split $overblock \n] - } else { - set scheme 3 - switch -- $scheme { - 0 { - #one big chunk - set inputchunks [list $overblock] - } - 1 { - set inputchunks [punk::ansi::ta::split_codes $overblock] - } - 2 { - - #split into lines if possible first - then into plaintext/ansi-sequence chunks ? - set inputchunks [list ""] ;#put an empty plaintext split in for starters - set i 1 - set lines [split $overblock \n] - foreach ln $lines { - if {$i < [llength $lines]} { - append ln \n - } - set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? - set lastpt [lindex $inputchunks end] - lset inputchunks end [tcl::string::cat $lastpt [lindex $sequence_split 0]] - lappend inputchunks {*}[lrange $sequence_split 1 end] - incr i - } - } - 3 { - #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice - set lflines [list] - set inputchunks [split $overblock \n] - foreach ln $inputchunks { - append ln \n - lappend lflines $ln - } - if {[llength $lflines]} { - lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] - } - set inputchunks $lflines[unset lflines] - - } - } - } - - - #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height - #lassign [blocksize $overblock] _w overblock_width _h overblock_height - - - set replay_codes_underlay [tcl::dict::create 1 ""] - #lappend replay_codes_overlay "" - set replay_codes_overlay "" - set unapplied "" - set cursor_saved_position [tcl::dict::create] - set cursor_saved_attributes "" - - - set outputlines $underlines - set overidx 0 - - #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext - set row 1 - if {$data_mode} { - set col [_get_row_append_column $row] - } else { - set col $opt_startcolumn - } - - set instruction_stats [tcl::dict::create] - - set loop 0 - #while {$overidx < [llength $inputchunks]} { } - - while {[llength $inputchunks]} { - #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" - set overtext [lpop inputchunks 0] - if {![tcl::string::length $overtext]} { - incr loop - continue - } - #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" - set undertext [lindex $outputlines [expr {$row -1}]] - set renderedrow $row - - #renderline pads each underaly line to width with spaces and should track where end of data is - - - #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] - if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [tcl::string::cat [tcl::dict::get $replay_codes_underlay $row] $undertext] - } - #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l - set LASTCALL [list -info 1 -insert_mode $insert_mode -autowrap_mode $autowrap_mode -transparent $opt_transparent -width $colwidth -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -cursor_column $col -cursor_row $row $undertext $overtext] - set rinfo [renderline -experimental $opt_experimental\ - -info 1\ - -insert_mode $insert_mode\ - -cursor_restore_attributes $cursor_saved_attributes\ - -autowrap_mode $autowrap_mode\ - -transparent $opt_transparent\ - -width $colwidth\ - -exposed1 $opt_exposed1\ - -exposed2 $opt_exposed2\ - -overflow $opt_overflow\ - -cursor_column $col\ - -cursor_row $row\ - $undertext\ - $overtext\ - ] - set instruction [tcl::dict::get $rinfo instruction] - set insert_mode [tcl::dict::get $rinfo insert_mode] - set autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;# - #set reverse_mode [tcl::dict::get $rinfo reverse_mode];#how to support in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? - set rendered [tcl::dict::get $rinfo result] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set overflow_right_column [tcl::dict::get $rinfo overflow_right_column] - set unapplied [tcl::dict::get $rinfo unapplied] - set unapplied_list [tcl::dict::get $rinfo unapplied_list] - set post_render_col [tcl::dict::get $rinfo cursor_column] - set post_render_row [tcl::dict::get $rinfo cursor_row] - set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position] - set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes] - set visualwidth [tcl::dict::get $rinfo visualwidth] - set insert_lines_above [tcl::dict::get $rinfo insert_lines_above] - set insert_lines_below [tcl::dict::get $rinfo insert_lines_below] - tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay] - #lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - - - - #-- todo - detect looping properly - if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { - puts stderr "overtype::renderspace loop?" - puts [ansistring VIEW $rinfo] - break - } - #-- - - if {[tcl::dict::size $c_saved_pos] >= 1} { - set cursor_saved_position $c_saved_pos - set cursor_saved_attributes $c_saved_attributes - } - - - set overflow_handled 0 - - - - set nextprefix "" - - - #todo - handle potential insertion mode as above for cursor restore? - #keeping separate branches for debugging - review and merge as appropriate when stable - tcl::dict::incr instruction_stats $instruction - switch -- $instruction { - {} { - if {$test_mode == 0} { - incr row - if {$data_mode} { - set col [_get_row_append_column $row] - if {$col > $colwidth} { - - } - } else { - set col 1 - } - } else { - #lf included in data - set row $post_render_row - set col $post_render_col - - #set col 1 - #if {$post_render_row != $renderedrow} { - # set col 1 - #} else { - # set col $post_render_col - #} - } - } - up { - - #renderline knows it's own line number, and knows not to go above row l - #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. - #row returned should be correct. - #column may be the overflow column - as it likes to report that to the caller. - - #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. - #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review - #puts stderr "up $post_render_row" - #puts stderr "$rinfo" - - #puts stdout "1 row:$row col $col" - set row $post_render_row - #data_mode (naming?) determines if we move to end of existing data or not. - #data_mode 0 means ignore existing line length and go to exact column - #set by -experimental flag - if {$data_mode == 0} { - set col $post_render_col - } else { - #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data - #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $colwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $colwidth - } - } - - #puts stdout "2 row:$row col $col" - #puts stdout "-----------------------" - #puts stdout $rinfo - #flush stdout - } - down { - if {$data_mode == 0} { - #renderline doesn't know how far down we can go.. - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } - set row $post_render_row - set col $post_render_col - } else { - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $colwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $colwidth - } - - } - } - restore_cursor { - #testfile belinda.ans uses this - - #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" - if {[tcl::dict::exists $cursor_saved_position row]} { - set row [tcl::dict::get $cursor_saved_position row] - set col [tcl::dict::get $cursor_saved_position column] - #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" - #set nextprefix $cursor_saved_attributes - #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes - #set replay_codes_overlay $cursor_saved_attributes - set cursor_saved_position [tcl::dict::create] - set cursor_saved_attributes "" - } else { - #TODO - #?restore without save? - #should move to home position and reset ansi SGR? - #puts stderr "overtype::renderspace cursor_restore without save data available" - } - #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it - #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. - if {!$overflow_handled && $overflow_right ne ""} { - #wrap before restore? - possible effect on saved cursor position - #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc - #we can just insert another call to renderline to solve this.. ? - #It would perhaps be more properly handled as a queue of instructions from our initial renderline call - #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks - - puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" - - set sub_info [overtype::renderline -info 1 -width $colwidth -insert_mode $insert_mode -autowrap_mode $autowrap_mode -overflow [tcl::dict::get $opts -overflow] "" $overflow_right] - set foldline [tcl::dict::get $sub_info result] - set insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed.. - set autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. - linsert outputlines $renderedrow $foldline - #review - row & col set by restore - but not if there was no save.. - } - set overflow_handled 1 - - } - move { - ######## - if {$post_render_row > [llength $outputlines]} { - #Ansi moves need to create new lines ? - #if {$opt_appendlines} { - # set diff [expr {$post_render_row - [llength $outputlines]}] - # if {$diff > 0} { - # lappend outputlines {*}[lrepeat $diff ""] - # } - # set row $post_render_row - #} else { - set row [llength $outputlines] - #} - } else { - set row $post_render_row - } - ####### - set col $post_render_col - #overflow + unapplied? - } - lf_start { - #raw newlines - must be test_mode - # ---------------------- - #test with fruit.ans - #test - treating as newline below... - #append rendered $overflow_right - #set overflow_right "" - set row $renderedrow - incr row - if {$row > [llength $outputlines]} { - lappend outputlines "" - } - set col $opt_startcolumn - # ---------------------- - } - lf_mid { - - if 0 { - #set rhswidth [punk::ansi::printing_length $overflow_right] - #only show debug when we have overflow? - set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] - set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] - - set rhs "" - if {$overflow_right ne ""} { - set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $overflow_right]] - set rhs [textblock::frame -title overflow_right $rhs] - } - puts [textblock::join $lhs " $post_render_col " $rhs] - } - - if {!$test_mode} { - #rendered - append rendered $overflow_right - #set replay_codes_overlay "" - set overflow_right "" - - - set row $renderedrow - - set col $opt_startcolumn - incr row - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - set edit_mode 0 - if {$edit_mode} { - set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] - set overflow_right "" - set unapplied "" - set row $post_render_row - #set col $post_render_col - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - append rendered $overflow_right - set overflow_right "" - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } - } - } - lf_overflow { - #linefeed after colwidth e.g at column 81 for an 80 col width - #we may also have other control sequences that came after col 80 e.g cursor save - - if 0 { - set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] - set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] - set rhs "" - - #assertion - there should be no overflow.. - puts $lhs - } - assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right - - set row $post_render_row - #set row $renderedrow - #incr row - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - set col $opt_startcolumn - - } - newlines_above { - #we get a newlines_above instruction when received at column 1 - #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) - #in other cases - we want to treat at column 1 the same as any other - - puts "--->newlines_above" - puts "rinfo: $rinfo" - #renderline doesn't advance the row for us - the caller has the choice to implement or not - set row $post_render_row - set col $post_render_col - if {$insert_lines_above > 0} { - set row $renderedrow - set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] - incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above - #? set row $post_render_row #can renderline tell us? - } - } - newlines_below { - #obsolete? - use for ANSI insert lines sequence - if {$data_mode == 0} { - puts --->nl_below - set row $post_render_row - set col $post_render_col - if {$insert_lines_below == 1} { - if {$test_mode == 0} { - set row $renderedrow - set outputlines [linsert $outputlines [expr {$renderedrow }] {*}[lrepeat $insert_lines_below ""]] ;#note - linsert can add to end too - incr row $insert_lines_below - set col $opt_startcolumn - } else { - #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] - #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] - #set rhs "" - #if {$overflow_right ne ""} { - # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] - # set rhs [textblock::frame -title overflow_right $rhs] - #} - #puts [textblock::join $lhs $rhs] - - #rendered - append rendered $overflow_right - # - - - set overflow_right "" - set row $renderedrow - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat $insert_lines_below ""] - } - incr row $insert_lines_below - set col $opt_startcolumn - - - - } - } - } else { - set row $post_render_row - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } else { - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $colwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $colwidth - } - } - } - } - wrapmoveforward { - #doesn't seem to be used by fruit.ans testfile - #used by dzds.ans - #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO - set c $colwidth - set r $post_render_row - if {$post_render_col > $colwidth} { - set i $c - while {$i <= $post_render_col} { - if {$c == $colwidth+1} { - incr r - if {$opt_appendlines} { - if {$r < [llength $outputlines]} { - lappend outputlines "" - } - } - set c $opt_startcolumn - } else { - incr c - } - incr i - } - set col $c - } else { - #why are we getting this instruction then? - puts stderr "wrapmoveforward - test" - set r [expr {$post_render_row +1}] - set c $post_render_col - } - set row $r - set col $c - } - wrapmovebackward { - set c $colwidth - set r $post_render_row - if {$post_render_col < 1} { - set c 1 - set i $c - while {$i >= $post_render_col} { - if {$c == 0} { - if {$r > 1} { - incr r -1 - set c $colwidth - } else { - #leave r at 1 set c 1 - #testfile besthpav.ans first line top left border alignment - set c 1 - break - } - } else { - incr c -1 - } - incr i -1 - } - set col $c - } else { - puts stderr "Wrapmovebackward - but postrendercol >= 1???" - } - set row $r - set col $c - } - overflow { - #normal single-width grapheme overflow - #puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" - set row $post_render_row ;#renderline will not advance row when reporting overflow char - if {$autowrap_mode} { - incr row - set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? - } else { - #this works for test_mode (which should become the default) - but could give a bad result otherwise - review - add tests fix. - set col $post_render_col - #set unapplied "" ;#this seems wrong? - #set unapplied [tcl::string::range $unapplied 1 end] - #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs - #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate - #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' - set idx 0 - set next_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set next_grapheme_index $idx - break - } - incr idx - } - assert {$next_grapheme_index >= 0} - #drop the overflow grapheme - keeping all codes in place. - set unapplied [join [lreplace $unapplied_list $next_grapheme_index $next_grapheme_index] ""] - #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines - - set overflow_handled 1 - #handled by dropping overflow if any - } - } - overflow_splitchar { - set row $post_render_row ;#renderline will not advance row when reporting overflow char - - #2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts - #todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc - if {$autowrap_mode} { - if {$colwidth < 2} { - #edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } else { - set col $opt_startcolumn - incr row - } - } else { - set overflow_handled 1 - #handled by dropping entire overflow if any - if {$colwidth < 2} { - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } - } - - } - vt { - - #can vt add a line like a linefeed can? - set row $post_render_row - set col $post_render_col - } - default { - puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'" - } - - } - - - if {!$opt_overflow && !$autowrap_mode} { - #not allowed to overflow column or wrap therefore we get overflow data to truncate - if {[tcl::dict::get $opts -ellipsis]} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim [punk::ansi::stripansi $lostdata]] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::right $rendered $opt_ellipsistext] - } - set overflow_handled 1 - } else { - #no wrap - no ellipsis - silently truncate - set overflow_handled 1 - } - } - - - - if {$renderedrow <= [llength $outputlines]} { - lset outputlines [expr {$renderedrow-1}] $rendered - } else { - if {$opt_appendlines} { - lappend outputlines $rendered - } else { - #? - lset outputlines [expr {$renderedrow-1}] $rendered - } - } - - if {!$overflow_handled} { - append nextprefix $overflow_right - } - - append nextprefix $unapplied - - if 0 { - if {$nextprefix ne ""} { - set nextoveridx [expr {$overidx+1}] - if {$nextoveridx >= [llength $inputchunks]} { - lappend inputchunks $nextprefix - } else { - #lset overlines $nextoveridx $nextprefix[lindex $overlines $nextoveridx] - set inputchunks [linsert $inputchunks $nextoveridx $nextprefix] - } - } - } - - if {$nextprefix ne ""} { - set inputchunks [linsert $inputchunks 0 $nextprefix] - } - - - incr overidx - incr loop - if {$loop >= $looplimit} { - puts stderr "overtype::renderspace looplimit reached ($looplimit)" - lappend outputlines "[a+ red bold] - looplimit $looplimit reached[a]" - set Y [a+ yellow bold] - set RST [a] - set sep_header ----DEBUG----- - set debugmsg "" - append debugmsg "${Y}${sep_header}${RST}" \n - append debugmsg "looplimit $looplimit reached\n" - append debugmsg "test_mode:$test_mode\n" - append debugmsg "data_mode:$data_mode\n" - append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[tcl::dict::get $LASTCALL -cursor_row]\n" - append debugmsg "prev_col :[tcl::dict::get $LASTCALL -cursor_column]\n" - tcl::dict::for {k v} $rinfo { - append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n - } - append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n - - puts stdout $debugmsg - #todo - config regarding error dumps rather than just dumping in working dir - set fd [open [pwd]/error_overtype.txt w] - puts $fd $debugmsg - close $fd - error $debugmsg - break - } - } - - set result [join $outputlines \n] - if {$info_mode} { - #emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window? - #append result \n$instruction_stats\n - } - return $result - } - - #todo - left-right ellipsis ? - proc centre {args} { - variable default_ellipsis_horizontal - if {[llength $args] < 2} { - error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} - } - - foreach {underblock overblock} [lrange $args end-1 end] break - - #todo - vertical vs horizontal overflow for blocks - set opts [tcl::dict::create\ - -bias left\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - ] - set argsflags [lrange $args 0 end-2] - foreach {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - # -- --- --- --- --- --- - - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w colwidth _h colheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {$colwidth - $overblock_width}] - if {$under_exposed_max > 0} { - #background block is wider - if {$under_exposed_max % 2 == 0} { - #even left/right exposure - set left_exposed [expr {$under_exposed_max / 2}] - } else { - set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division - if {[tcl::string::tolower [tcl::dict::get $opts -bias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $colwidth} { - set udiff [expr {$colwidth - $ulen}] - set undertext "$undertext[string repeat { } $udiff]" - } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] - - set overflowlength [expr {$overtext_datalen - $colwidth}] - #review - right-to-left langs should elide on left! - extra option required - - if {$overflowlength > 0} { - #overlay line wider or equal - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - set rendered [tcl::dict::get $rinfo result] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set unapplied [tcl::dict::get $rinfo unapplied] - #todo - get replay_codes from overflow_right instead of wherever it was truncated? - - #overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified - if {![tcl::dict::get $opts -overflow]} { - #lappend outputlines [tcl::string::range $overtext 0 [expr {$colwidth - 1}]] - #set overtext [tcl::string::range $overtext 0 $colwidth-1 ] - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - #don't use tcl::string::range on ANSI data - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::right $rendered $opt_ellipsistext] - } - } - } - lappend outputlines $rendered - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent $undertext $overtext] - } else { - #background block is wider than or equal to data for this line - #lappend outputlines [renderline -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - set rinfo [renderline -info 1 -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - lappend outputlines [tcl::dict::get $rinfo result] - } - set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - } - return [join $outputlines \n] - } - - #overtype::right is for a rendered ragged underblock and a rendered ragged overblock - #ie we can determine the block width for bost by examining the lines and picking the longest. - # - proc right {args} { - #NOT the same as align-right - which should be done to the overblock first if required - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? ?-transparent 0|? undertext overtext} - } - foreach {underblock overblock} [lrange $args end-1 end] break - - set opts [tcl::dict::create\ - -bias ignored\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -align "left"\ - ] - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_overflow [tcl::dict::get $opts -overflow] - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - set opt_align [tcl::dict::get $opts -align] - # -- --- --- --- --- --- - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w colwidth _h colheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {max(0,$colwidth - $overblock_width)}] - set left_exposed $under_exposed_max - - - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $colwidth} { - set udiff [expr {$colwidth - $ulen}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_align { - left { - set startoffset 0 - } - right { - set startoffset $odiff - } - default { - set half [expr {$odiff / 2}] - #set lhs [string repeat { } $half] - #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left - #set rhs [string repeat { } $righthalf] - set startoffset $half - } - } - } else { - set startoffset 0 ;#negative? - } - - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] - - set overflowlength [expr {$overtext_datalen - $colwidth}] - if {$overflowlength > 0} { - #raw overtext wider than undertext column - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] - set replay_codes [tcl::dict::get $rinfo replay_codes] - set rendered [tcl::dict::get $rinfo result] - if {!$opt_overflow} { - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] - #todo - overflow on left if allign = right?? - set rendered [overtype::right $rendered $ellipsis] - } - } - } - lappend outputlines $rendered - } else { - #padded overtext - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need overflow here - as although the overtext is short - it may oveflow due to the startoffset - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - lappend outputlines [tcl::dict::get $rinfo result] - } - set replay_codes [tcl::dict::get $rinfo replay_codes] - set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - } - - return [join $outputlines \n] - } - - proc left {args} { - overtype::block -blockalign left {*}$args - } - #overtype a (possibly ragged) underblock with a (possibly ragged) overblock - proc block {args} { - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-blockalign left|centre|right? ?-textalign left|centre|right? ?-overflow [1|0]? ?-transparent 0|? undertext overtext} - } - #foreach {underblock overblock} [lrange $args end-1 end] break - lassign [lrange $args end-1 end] underblock overblock - - set opts [tcl::dict::create\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -textalign "left"\ - -textvertical "top"\ - -blockalign "left"\ - -blockalignbias left\ - -blockvertical "top"\ - ] - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical { - tcl::dict::set opts $k $v - } - default { - error "overtype::block unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_overflow [tcl::dict::get $opts -overflow] - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - set opt_textalign [tcl::dict::get $opts -textalign] - set opt_blockalign [tcl::dict::get $opts -blockalign] - if {$opt_blockalign eq "center"} { - set opt_blockalign "centre" - } - # -- --- --- --- --- --- - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w colwidth _h colheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {max(0,$colwidth - $overblock_width)}] - - switch -- $opt_blockalign { - left { - set left_exposed 0 - } - right { - set left_exposed $under_exposed_max - } - centre { - if {$under_exposed_max > 0} { - #background block is wider - if {$under_exposed_max % 2 == 0} { - #even left/right exposure - set left_exposed [expr {$under_exposed_max / 2}] - } else { - set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division - if {[tcl::string::tolower [tcl::dict::get $opts -blockalignbias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - } - default { - set left_exposed 0 - } - } - - - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $colwidth} { - set udiff [expr {$colwidth - $ulen}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_textalign { - left { - set startoffset 0 - } - right { - set startoffset $odiff - } - default { - set half [expr {$odiff / 2}] - #set lhs [string repeat { } $half] - #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left - #set rhs [string repeat { } $righthalf] - set startoffset $half - } - } - } else { - set startoffset 0 ;#negative? - } - - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] - - set overflowlength [expr {$overtext_datalen - $colwidth}] - if {$overflowlength > 0} { - #raw overtext wider than undertext column - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] - set replay_codes [tcl::dict::get $rinfo replay_codes] - set rendered [tcl::dict::get $rinfo result] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set unapplied [tcl::dict::get $rinfo unapplied] - if {!$opt_overflow} { - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - #don't use tcl::string::range on ANSI data - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::block -blockalign right $rendered $opt_ellipsistext] - } - } - - #if {$opt_ellipsis} { - # set show_ellipsis 1 - # if {!$opt_ellipsiswhitespace} { - # #we don't want ellipsis if only whitespace was lost - # set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - # if {[tcl::string::trim $lostdata] eq ""} { - # set show_ellipsis 0 - # } - # } - # if {$show_ellipsis} { - # set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] - # #todo - overflow on left if allign = right?? - # set rendered [overtype::right $rendered $ellipsis] - # } - #} - } - lappend outputlines $rendered - } else { - #padded overtext - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need overflow here - as although the overtext is short - it may oveflow due to the startoffset - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set unapplied [tcl::dict::get $rinfo unapplied] - lappend outputlines [tcl::dict::get $rinfo result] - } - set replay_codes [tcl::dict::get $rinfo replay_codes] - set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - } - - return [join $outputlines \n] - } - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. - # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # - # - #-returnextra enables returning of overflow and length - #review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation? - #review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements - #(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char) - #todo - review transparency issues with single/double width characters - #bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer? - proc renderline {args} { - #*** !doctools - #[call [fun overtype::renderline] [arg args] ] - #[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell - #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts - #[para] This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that can be joined & framed for layout display within a unix or windows terminal - #[para] Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't affect another. - #[para] Calling on the punk::ansi library - it can coalesce codes to keep the size down. - #[para] It is a giant mess of doing exactly what common wisdom says not to do... lots at once. - #[para] renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a static underlay - #[para] The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous to a terminal screen - but it can also be ragged in line length, or just blank. - #[para] The overlay couuld be similar - in which case it may often be used to overwrite a column or section of the underlay. - #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. - # - #[para] renderline itself only deals with a single line - or sometimes a single character. It is generally called from a loop that does further terminal-like or textblock processing. - #[para] By suppyling the -info 1 option - it can return various fields indicating the state of the render. - #[para] The main 3 are the result, overflow_right, and unapplied. - #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. - - if {[llength $args] < 2} { - error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-overflow [1|0]? undertext overtext} - } - lassign [lrange $args end-1 end] under over - if {[string first \n $under] >= 0} { - error "overtype::renderline not allowed to contain newlines in undertext" - } - #if {[string first \n $over] >=0 || [string first \n $under] >= 0} { - # error "overtype::renderline not allowed to contain newlines" - #} - - #generally faster to create a new dict in the proc than to use a namespace variable to create dict once and link to variable (2024 8.6/8.7) - set opts [tcl::dict::create\ - -etabs 0\ - -width \uFFEF\ - -overflow 0\ - -transparent 0\ - -startcolumn 1\ - -cursor_column 1\ - -cursor_row ""\ - -insert_mode 1\ - -autowrap_mode 1\ - -reverse_mode 0\ - -info 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -cursor_restore_attributes ""\ - -cp437 0\ - -experimental {}\ - ] - #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller - - #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return - #An empty string for cursor_row tells us we have no info about our own row context, and to return with an unapplied string if any row move occurs - - #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency or overflow - #todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error - - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -experimental - -cp437 - -width - -overflow - -transparent - -startcolumn - -cursor_column - -cursor_row - -insert_mode - -autowrap_mode - -reverse_mode - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { - tcl::dict::set opts $k $v - } - default { - error "overtype::renderline unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_width [tcl::dict::get $opts -width] - set opt_etabs [tcl::dict::get $opts -etabs] - set opt_overflow [tcl::dict::get $opts -overflow] - set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay - set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay - set opt_row_context [tcl::dict::get $opts -cursor_row] - if {[string length $opt_row_context]} { - if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } { - error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) - set opt_insert_mode [tcl::dict::get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) - #default is for overtype - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_autowrap_mode [tcl::dict::get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line - set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] ;#DECSNM - # -- --- --- --- --- --- --- --- --- --- --- --- - set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] - - set test_mode 0 - set cp437_glyphs [tcl::dict::get $opts -cp437] - foreach e [tcl::dict::get $opts -experimental] { - switch -- $e { - test_mode { - set test_mode 1 - set cp437_glyphs 1 - } - } - } - set test_mode 1 ;#try to elminate - set cp437_map [tcl::dict::create] - if {$cp437_glyphs} { - set cp437_map [set ::punk::ansi::cp437_map] - #for cp437 images we need to map these *after* splitting ansi - #some old files might use newline for its glyph.. but we can't easily support that. - #Not sure how old files did it.. maybe cr lf in sequence was newline and any lone cr or lf were displayed as glyphs? - tcl::dict::unset cp437_map \n - } - - set opt_transparent [tcl::dict::get $opts -transparent] - if {$opt_transparent eq "0"} { - set do_transparency 0 - } else { - set do_transparency 1 - if {$opt_transparent eq "1"} { - set opt_transparent {[\s]} - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_returnextra [tcl::dict::get $opts -info] - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - # -- --- --- --- --- --- --- --- --- --- --- --- - - if {$opt_row_context eq ""} { - set cursor_row 1 - } else { - set cursor_row $opt_row_context - } - - - #----- - # - if {[info exists punk::console::tabwidth]} { - #punk console is updated if punk::console::set_tabstop_width is used or rep is started/restarted - #It is way too slow to test the current width by querying the terminal here - so it could conceivably get out of sync - #todo - we also need to handle the new threaded repl where console config is in a different thread. - # - also - concept of sub-regions being mini-consoles with their own settings - 'id' for console, or use in/out channels as id? - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - - set overdata $over - if {!$cp437_glyphs} { - #REVIEW! tabify will give different answers for an ANSI colourised string vs plain text - if {!$opt_etabs} { - if {[string first \t $under] >= 0} { - #set under [textutil::tabify::untabify2 $under] - set under [textutil::tabify::untabifyLine $under $tw] - } - if {[string first \t $over] >= 0} { - #set overdata [textutil::tabify::untabify2 $over] - set overdata [textutil::tabify::untabifyLine $over $tw] - } - } - } - #------- - - #ta_detect ansi and do simpler processing? - - #we repeat tests for grapheme width in different loops - rather than create another datastructure to store widths based on column, - #we'll use the grapheme_width_cached function as a lookup table of all graphemes encountered - as there will often be repeats in different positions anyway. - - # -- --- --- --- --- --- --- --- - if {$under ne ""} { - if {[punk::ansi::ta::detect $under]} { - set undermap [punk::ansi::ta::split_codes_single $under] - } else { - #single plaintext part - set undermap [list $under] - } - } else { - set undermap [list] - } - set understacks [list] - set understacks_gx [list] - - set i_u -1 ;#underlay may legitimately be empty - set undercols [list] - set u_codestack [list] - #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway - set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) - #set pt_underchars "" ;#for string_columns length calculation for overflow 0 truncation - set remainder [list] ;#for returnextra - foreach {pt code} $undermap { - #pt = plain text - #append pt_underchars $pt - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - foreach grapheme [punk::char::grapheme_split $pt] { - #an ugly hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. - #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. - switch -- $grapheme { - " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - set width 1 - } - default { - if {$grapheme eq "\u0000"} { - #use null as empty cell representation - review - #use of this will probably collide with some application at some point - #consider an option to set the empty cell character - set width 1 - } else { - set width [grapheme_width_cached $grapheme] - #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length - #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI - #todo - default to off and add a flag (?) to enable this substitution - set sub_stray_escapes 0 - if {$sub_stray_escapes && $width == 0} { - if {$grapheme eq "\x1b"} { - set gvis [ansistring VIEW $grapheme] - set grapheme $gvis - set width 1 - } - } - } - } - } - #set width [grapheme_width_cached $grapheme] - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - - lappend undercols $grapheme - if {$width > 1} { - #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) - #but what about emoji combinations etc - can they be wider than 2? - #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - lappend undercols "" - } - } - - #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here - - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc - if {$code ne ""} { - set c1c2 [tcl::string::range $code 0 1] - - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - ] $c1c2] 0 3];# leadernorm is 1st 2 chars mapped to normalised indicator - or is original 2 chars - - switch -- $leadernorm { - 7CSI - 8CSI { - #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse - #REVIEW - what else could end in m but be mistaken as a normal SGR code here? - set maybemouse "" - if {[tcl::string::index $c1c2 0] eq "\x1b"} { - set maybemouse [tcl::string::index $code 2] - } - - if {$maybemouse ne "<" && [tcl::string::index $code end] eq "m"} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set u_codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set u_codestack [list $code] - } else { - #basic simplification first.. straight dups - set dup_posns [lsearch -all -exact $u_codestack $code] ;#-exact because of square-bracket glob chars - set u_codestack [lremove $u_codestack {*}$dup_posns] - lappend u_codestack $code - } - } - } - 7GFX { - switch -- [tcl::string::index $code 2] { - "0" { - set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess - } - B { - set u_gx_stack [list] - } - } - } - default { - - } - - } - - #if {[punk::ansi::codetype::is_sgr_reset $code]} { - # #set u_codestack [list] - #} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - #} elseif {[punk::ansi::codetype::is_sgr $code]} { - #} else { - # #leave SGR stack as is - # if {[punk::ansi::codetype::is_gx_open $code]} { - # } elseif {[punk::ansi::codetype::is_gx_close $code]} { - # } - #} - } - #consider also if there are other codes that should be stacked..? - } - - if {!$test_mode} { - #fill columns to width with spaces, and carry over stacks - we will have to keep track of where the underlying data ends manually - TODO - #Specifying a width is suitable for terminal-like applications and text-blocks - if {$opt_width ne "\uFFEF"} { - if {[llength $understacks]} { - set cs $u_codestack - set gs $u_gx_stack - } else { - set cs [list] - set gs [list] - } - if {[llength $undercols]< $opt_width} { - set diff [expr {$opt_width- [llength $undercols]}] - if {$diff > 0} { - lappend undercols {*}[lrepeat $diff " "] - lappend understacks {*}[lrepeat $diff $cs] - lappend understacks_gx {*}[lrepeat $diff $gs] - } - } - } - } else { - #NULL empty cell indicator - if {$opt_width ne "\uFFEF"} { - if {[llength $understacks]} { - set cs $u_codestack - set gs $u_gx_stack - } else { - set cs [list] - set gs [list] - } - if {[llength $undercols]< $opt_width} { - set diff [expr {$opt_width- [llength $undercols]}] - if {$diff > 0} { - lappend undercols {*}[lrepeat $diff "\u0000"] - lappend understacks {*}[lrepeat $diff $cs] - lappend understacks_gx {*}[lrepeat $diff $gs] - } - } - } - - } - if {$opt_width ne "\uFFEF"} { - set colwidth $opt_width - } else { - set colwidth [llength $undercols] - } - - - if 0 { - # ----------------- - # if we aren't extending understacks & understacks_gx each time we incr idx above the undercols length.. this doesn't really serve a purpose - # Review. - # ----------------- - #replay code for last overlay position in input line - # whether or not we get that far - we need to return it for possible replay on next line - if {[llength $understacks]} { - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - } else { - #in case overlay onto emptystring as underlay - lappend understacks [list] - lappend understacks_gx [list] - } - # ----------------- - } - - #trailing codes in effect for underlay - if {[llength $u_codestack]} { - #set replay_codes_underlay [join $u_codestack ""] - set replay_codes_underlay [punk::ansi::codetype::sgr_merge_list {*}$u_codestack] - } else { - set replay_codes_underlay "" - } - - - # -- --- --- --- --- --- --- --- - #### - #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left of the right number of columns. - #this will be processed as transparent - and handle doublewidth underlay characters appropriately - set startpad_overlay [string repeat " " [expr {$opt_colstart -1}]] - append startpad_overlay $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - if {$startpad_overlay ne ""} { - if {[punk::ansi::ta::detect $startpad_overlay]} { - set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] - } else { - #single plaintext part - set overmap [list $startpad_overlay] - } - } else { - set overmap [list] - } - #set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] - #### - - #??? - set colcursor $opt_colstart - #TODO - make a little virtual column object - #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn - #need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess. - - - #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} - #as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes - - set overstacks [list] - set overstacks_gx [list] - - set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc) - set o_gxstack [list] - set pt_overchars "" - set i_o 0 - set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use - #experiment - set overlay_grapheme_control_stacks [list] - foreach {pt code} $overmap { - - #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - append pt_overchars $pt - #will get empty pt between adjacent codes - foreach grapheme [punk::char::grapheme_split $pt] { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack - } - - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc - #order of if-else based on assumptions: - # that pure resets are fairly common - more so than leading resets with other info - # that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. - if {$code ne ""} { - lappend overlay_grapheme_control_stacks $o_codestack - #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set o_codestack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars - set o_codestack [lremove $o_codestack {*}$dup_posns] - lappend o_codestack $code - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[regexp {\x1b7|\x1b\[s} $code]} { - #experiment - #cursor_save - for the replays review. - #jmn - #set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - lappend overlay_grapheme_control_list [list other $code] - } elseif {[regexp {\x1b8|\x1b\[u} $code]} { - #experiment - #cursor_restore - for the replays - set o_codestack [list $temp_cursor_saved] - lappend overlay_grapheme_control_list [list other $code] - } else { - if {[punk::ansi::codetype::is_gx_open $code]} { - set o_gxstack [list "gx0_on"] - lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } elseif {[punk::ansi::codetype::is_gx_close $code]} { - set o_gxstack [list] - lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } else { - lappend overlay_grapheme_control_list [list other $code] - } - } - } - - } - #replay code for last overlay position in input line - should take account of possible trailing sgr code after last grapheme - set max_overlay_grapheme_index [expr {$i_o -1}] - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - - #set replay_codes_overlay [join $o_codestack ""] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - - #if {[tcl::dict::exists $overstacks $max_overlay_grapheme_index]} { - # set replay_codes_overlay [join [tcl::dict::get $overstacks $max_overlay_grapheme_index] ""] - #} else { - # set replay_codes_overlay "" - #} - # -- --- --- --- --- --- --- --- - - - #potential problem - combinining diacritics directly following control chars like \r \b - - # -- --- --- - #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 - if {$opt_overflow} { - #somewhat counterintuitively - overflow true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. - set overflow_idx -1 - } else { - #overflow zero - we can't grow beyond our column width - so we get ellipsis or truncation - if {$opt_width ne "\uFFEF"} { - set overflow_idx [expr {$opt_width}] - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - } - # -- --- --- - - set outcols $undercols ;#leave undercols as is, outcols can potentially be appended to. - - set unapplied "" ;#if we break for move row (but not for /v ?) - set unapplied_list [list] - - set insert_lines_above 0 ;#return key - set insert_lines_below 0 - set instruction "" - - # -- --- --- - #cursor_save_dec, cursor_restore_dec etc - set cursor_restore_required 0 - set cursor_saved_attributes "" - set cursor_saved_position "" - # -- --- --- - - #set idx 0 ;# line index (cursor - 1) - #set idx [expr {$opt_colstart + $opt_colcursor} -1] - - #idx is the per column output index - set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1 - #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. - #(for now we are incrementing/decrementing both in sync - which is a bit silly) - set cursor_column $opt_colcursor - - #idx_over is the per grapheme overlay index - set idx_over -1 - - - #movements only occur within the overlay range. - #an underlay is however not necessary.. e.g - #renderline -overflow 1 "" data - #foreach {pt code} $overmap {} - set insert_mode $opt_insert_mode ;#default 1 - set autowrap_mode $opt_autowrap_mode ;#default 1 - - #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM - #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} - #set re_row_move {\x1b\[([0-9]*)(A|B)$} - #set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? - #set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} - #set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)! - #set re_cursor_restore {\x1b\[u$} - #set re_cursor_save_dec {\x1b7$} - #set re_cursor_restore_dec {\x1b8$} - #set re_other_single {\x1b(D|M|E)$} - #set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins - - #puts "-->$overlay_grapheme_control_list<--" - #puts "-->overflow_idx: $overflow_idx" - for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} { - set gc [lindex $overlay_grapheme_control_list $gci] - lassign $gc type item - - #emit plaintext chars first using existing SGR codes from under/over stack as appropriate - #then check if the following code is a cursor movement within the line and adjust index if so - #foreach ch $overlay_graphemes {} - switch -- $type { - g { - set ch $item - incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. - if {($idx < ($opt_colstart -1))} { - incr idx [grapheme_width_cached $ch] - continue - } - #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width - set within_undercols [expr {$idx <= $colwidth-1}] - - #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters - #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, - #on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1. - #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable - #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE - - set chtest [tcl::string::map [list \n \x85 \b \r \v \x7f ] $ch] - #puts --->chtest:$chtest - #specials - each shoud have it's own test of what to do if it happens after overflow_idx reached - switch -- $chtest { - "" { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - if {$idx == 0} { - #puts "---a at col 1" - #linefeed at column 1 - #leave the overflow_idx ;#? review - set instruction lf_start ;#specific instruction for newline at column 1 - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { - #linefeed after final column - #puts "---c at overflow_idx=$overflow_idx" - incr cursor_row - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 - set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } else { - #linefeed occurred in middle or at end of text - #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" - incr cursor_row - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 - set instruction lf_mid - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } - - } - "" { - #will we want/need to use raw for keypresses in terminal? (terminal with LNM in standard reset mode means enter= this is the usual config for terminals) - #So far we are assuming the caller has translated to and handle above.. REVIEW. - - #consider also the old space-carriagereturn softwrap convention used in some terminals. - #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. - set idx [expr {$opt_colstart -1}] - set cursor_column $opt_colstart ;#? - } - "" { - #literal backspace char - not necessarily from keyboard - #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype - #(important for -transparent option - hence replacement chars for half-exposed etc) - #review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR) - if {$idx > ($opt_colstart -1)} { - incr idx -1 - incr cursor_column -1 - } else { - set flag 0 - if $flag { - #review - conflicting requirements? Need a different sequence for destructive interactive backspace? - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction backspace_at_start - break - } - } - } - "" { - #literal del character - some terminals send just this for what is generally expected to be a destructive backspace - #We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect. - priv::render_delchar $idx - } - "" { - #end processing this overline. rest of line is remainder. cursor for column as is. - #REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?) - #e.g it could be configured to jump down 6 rows. - #On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed. - #todo? - incr cursor_row - set overflow_idx $idx - #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction vt - break - } - default { - if {$overflow_idx != -1} { - #review - how to check arbitrary length item such as tab is going to overflow .. before we get to overflow_idx? - #call grapheme_width_cached on each ch, or look for tab specifically as it's currently the only known reason to have a grapheme width > 2? - #we need to decide what a tab spanning the overflow_idx means and how it affects wrap etc etc - if {$idx == $overflow_idx-1} { - set owidth [grapheme_width_cached $ch] - if {$owidth == 2} { - #review split 2w overflow? - #we don't want to make the decision here to split a 2w into replacement characters at end of line and beginning of next line - #better to consider the overlay char as unable to be applied to the line - #render empty column(?) - and reduce overlay grapheme index by one so that the current ch goes into unapplied - #throwing back to caller with instruction complicates its job - but is necessary to avoid making decsions for it here. - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #change the overflow_idx - set overflow_idx $idx - incr idx - incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used - priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci - #throw back to caller's loop - add instruction to caller as this is not the usual case - #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line - set instruction overflow_splitchar - break - } elseif {$owidth > 2} { - #? tab? - #TODO! - puts stderr "overtype::renderline long overtext grapheme '[ansistring VIEW -lf 1 -vt 1 $ch]' not handled" - #tab of some length dependent on tabstops/elastic tabstop settings? - } - } elseif {$idx >= $overflow_idx} { - #jmn? - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] - #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #don't incr idx beyond the overflow_idx - #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied - incr idx_over -1 - #priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too - priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# - set instruction overflow - break - } - } else { - #review. - #This corresponds to opt_overflow being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) - } - - if {($do_transparency && [regexp $opt_transparent $ch])} { - #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) - if {$idx > [llength $outcols]-1} { - lappend outcols " " - #tcl::dict::set understacks $idx [list] ;#review - use idx-1 codestack? - lset understacks $idx [list] - incr idx - incr cursor_column - } else { - #todo - punk::char::char_width - set g [lindex $outcols $idx] - set uwidth [grapheme_width_cached $g] - if {[lindex $outcols $idx] eq ""} { - #2nd col of 2-wide char in underlay - incr idx - incr cursor_column - } elseif {$uwidth == 0} { - #e.g control char ? combining diacritic ? - incr idx - incr cursor_column - } elseif {$uwidth == 1} { - set owidth [grapheme_width_cached $ch] - incr idx - incr cursor_column - if {$owidth > 1} { - incr idx - incr cursor_column - } - } elseif {$uwidth > 1} { - if {[grapheme_width_cached $ch] == 1} { - if {!$insert_mode} { - #normal singlewide transparent overlay onto double-wide underlay - set next_pt_overchar [tcl::string::index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay - if {$next_pt_overchar eq ""} { - #special-case trailing transparent - no next_pt_overchar - incr idx - incr cursor_column - } else { - if {[regexp $opt_transparent $next_pt_overchar]} { - incr idx - incr cursor_column - } else { - #next overlay char is not transparent.. first-half of underlying 2wide char is exposed - #priv::render_addchar $idx $opt_exposed1 [tcl::dict::get $overstacks $idx_over] [tcl::dict::get $overstacks_gx $idx_over] $insert_mode - priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } - } else { - #? todo - decide what transparency even means for insert mode - incr idx - incr cursor_column - } - } else { - #2wide transparency over 2wide in underlay - review - incr idx - incr cursor_column - } - } - } - } else { - - set idxchar [lindex $outcols $idx] - #non-transparent char in overlay or empty cell - if {$idxchar eq "\u0000"} { - #empty/erased cell indicator - set uwidth 1 - } else { - set uwidth [grapheme_width_cached $idxchar] - } - if {$within_undercols} { - if {$idxchar eq ""} { - #2nd col of 2wide char in underlay - if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 - #JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme - #e.g renderline \uFF21\uFF21--- a\uFF23\uFF23 - #vs - # renderline -startcolumn 2 \uFF21---- \uFF23 - if {[lindex $outcols $idx-1] != ""} { - #verified it's an empty following a filled - so it's a legit underlay remnant (REVIEW - when would it not be??) - #reset previous to an exposed 1st-half - but leave understacks code as is - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 - } - incr idx - } else { - set prevcolinfo [lindex $outcols $idx-1] - #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right - #REVIEW - this leaves a replacement character permanently in our columns.. but it is consistent regarding length (?) - #The alternative is to disallow insertion at a column cursor that is at 2nd half of 2wide char - #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises - #It is perhaps best avoided at another level and try to make renderline do exactly as it's told - #the advantage of this 2w splitting method is that the inserted character ends up in exactly the column we expect. - priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 ;#replace not insert - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 1 ;#insert - same index - if {$prevcolinfo ne ""} { - #we've split the 2wide - it may already have been rendered as an exposed1 - but not for example if our startcolumn was current idx - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 ;#replace not insert - } ;# else?? - incr idx - } - if {$cursor_column < [llength $outcols] || $overflow_idx == -1} { - incr cursor_column - } - } elseif {$uwidth == 0} { - #what if this is some other c0/c1 control we haven't handled specifically? - - #by emitting a preceding empty-string column - we associate whatever this char is with the preceeding non-zero-length character and any existing zero-lengths that follow it - #e.g combining diacritic - increment before over char REVIEW - #arguably the previous overchar should have done this - ie lookahead for combiners? - #if we can get a proper grapheme_split function - this should be easier to tidy up. - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column 2 - - if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { - set cursor_column [llength $outcols] - } - } elseif {$uwidth == 1} { - #includes null empty cells - set owidth [grapheme_width_cached $ch] - if {$owidth == 1} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - } else { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #if next column in underlay empty - we've overwritten first half of underlying 2wide grapheme - #replace with rhs exposure in case there are no more overlay graphemes coming - use underlay's stack - if {([llength $outcols] >= $idx +2) && [lindex $outcols $idx+1] eq ""} { - priv::render_addchar [expr {$idx+1}] $opt_exposed2 [lindex $understacks $idx+1] [lindex $understacks_gx $idx+1] $insert_mode - } - incr idx - } - if {($cursor_column < [llength $outcols]) || $overflow_idx == -1 || $test_mode} { - incr cursor_column - } - } elseif {$uwidth > 1} { - set owidth [grapheme_width_cached $ch] - if {$owidth == 1} { - #1wide over 2wide in underlay - if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char - } else { - #insert mode just pushes all to right - no exposition char here - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } else { - #2wide over 2wide - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx 2 - incr cursor_column 2 - } - - if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { - set cursor_column [llength $outcols] - } - } - } else { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - if {$overflow_idx !=-1 && !$test_mode} { - #overflow - if {$cursor_column > [llength $outcols]} { - set cursor_column [llength $outcols] - } - } - } - } - } - } ;# end switch - - - } - other { - #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. - #we should probably therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore - set code [tcl::string::map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $item] - #since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied' - - set matchinfo [list] - - #remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI - #probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping - #review - cost/benefit of function calls within these switch-arms instead of inline code? - - set c1 [tcl::string::index $code 0] - set c1c2c3 [tcl::string::range $code 0 2] - #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} - #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. - #(surprising - but presumably ) - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[< 1006\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\] 7OSC\ - \x9d 8OSC\ - \x1b 7ESC\ - ] $c1c2c3] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars - - #we leave the tail of the code unmapped for now - switch -- $leadernorm { - 1006 { - #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html - #SGR (1006) CSI < followed by colon separated encoded-button-value,px,py ordinates and final M for button press m for button release - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] - } - 7CSI - 7OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] - } - 7ESC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - 8CSI - 8OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - default { - #we haven't made a mapping for this - set codenorm $code - } - } - - #we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables. - switch -- $leadernorm { - 1006 { - #TODO - # - switch -- [tcl::string::index $codenorm end] { - M { - puts stderr "mousedown $codenorm" - } - m { - puts stderr "mouseup $codenorm" - } - } - - } - {7CSI} - {8CSI} { - set param [tcl::string::range $codenorm 4 end-1] - #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" - switch -- [tcl::string::index $codenorm end] { - D { - #Col move - #puts stdout "<-back" - #cursor back - #left-arrow/move-back when ltr mode - set num $param - if {$num eq ""} {set num 1} - - set version 2 - if {$version eq "2"} { - #todo - startcolumn offset! - if {$cursor_column - $num >= 1} { - incr idx -$num - incr cursor_column -$num - } else { - if {!$autowrap_mode} { - set cursor_column 1 - set idx 0 - } else { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr cursor_column -$num - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction wrapmovebackward - break - } - } - } else { - incr idx -$num - incr cursor_column -$num - if {$idx < $opt_colstart-1} { - #wrap to previous line and position cursor at end of data - set idx [expr {$opt_colstart-1}] - set cursor_column $opt_colstart - } - } - } - C { - #Col move - #puts stdout "->forward" - #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. - #cursor forward - #right-arrow/move forward - set num $param - if {$num eq ""} {set num 1} - - #todo - retrict to moving 1 position past datalen? restrict to column width? - #should ideally wrap to next line when interactive and not on last row - #(some ansi art seems to expect this behaviour) - #This presumably depends on the terminal's wrap mode - #e.g DECAWM autowrap mode - # CSI ? 7 h - set: autowrap (also tput smam) - # CSI ? 7 l - reset: no autowrap (also tput rmam) - set version 2 - if {$version eq "2"} { - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$test_mode && $cursor_column == $max+1} { - #move_forward while in overflow - incr cursor_column -1 - } - - if {($cursor_column + $num) <= $max} { - incr idx $num - incr cursor_column $num - } else { - if {$autowrap_mode} { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #jmn - if {$idx == $overflow_idx} { - incr num - } - - #horizontal movement beyond line extent needs to wrap - throw back to caller - #we may have both overflow_rightand unapplied data - #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) - #leave row as is - caller will need to determine how many rows the column-movement has consumed - incr cursor_column $num ;#give our caller the necessary info as columns from start of row - #incr idx_over - #should be gci following last one applied - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction wrapmoveforward - break - } else { - set cursor_column $max - set idx [expr {$cursor_column -1}] - } - } - } else { - if {!$opt_overflow || ($cursor_column + $num) <= [llength $outcols+1]} { - incr idx $num - incr cursor_column $num - } else { - if {!$insert_mode} { - #block editing style with arrow keys - #overtype mode - set idxstart $idx - set idxend [llength $outcols] - set moveend [expr {$idxend - $idxstart}] - if {$moveend < 0} {set moveend 0} ;#sanity? - #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" - incr idx $moveend - incr cursor_column $moveend - #if {[tcl::dict::exists $understacks $idx]} { - # set stackinfo [tcl::dict::get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext - #} else { - # set stackinfo [list] - #} - if {$idx < [llength $understacks]} { - set stackinfo [lindex $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext - } else { - set stackinfo [list] - } - if {$idx < [llength $understacks_gx]} { - #set gxstackinfo [tcl::dict::get $understacks_gx $idx] - set gxstackinfo [lindex $understacks_gx $idx] - } else { - set gxstackinfo [list] - } - #pad outcols - set movemore [expr {$num - $moveend}] - #assert movemore always at least 1 or we wouldn't be in this branch - for {set m 1} {$m <= $movemore} {incr m} { - incr idx - incr cursor_column - priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode - } - } else { - #normal - insert - incr idx $num - incr cursor_column $num - if {$idx > [llength $outcols]} { - set idx [llength $outcols];#allow one beyond - for adding character at end of line - set cursor_column [expr {[llength $outcols]+1}] - } - } - } - } - } - G { - #Col move - #move absolute column - #adjust to colstart - as column 1 is within overlay - #??? - set idx [expr {$param + $opt_colstart -1}] - set cursor_column $param - error "renderline absolute col move ESC G unimplemented" - } - A { - #Row move - up - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set num $param - if {$num eq ""} {set num 1} - incr cursor_row -$num - - if {$cursor_row < 1} { - set cursor_row 1 - } - - #ensure rest of *overlay* is emitted to remainder - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction up - #retain cursor_column - break - } - B { - #Row move - down - set num $param - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move down - if {$num eq ""} {set num 1} - incr cursor_row $num - - - incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction down - #retain cursor_column - break - } - H - f { - #$re_both_move - lassign [split $param {;}] row col - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #lassign $matchinfo _match row col - - if {$col eq ""} {set col 1} - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$col > $max} { - set cursor_column $max - } else { - set cursor_column $col - } - set idx [expr {$cursor_column -1}] - - if {$row eq ""} {set row 1} - set cursor_row $row - if {$cursor_row < 1} { - set cursor_row 1 - } - - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - - } - X { - puts stderr "X - $param" - #ECH - erase character - if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase - priv::render_erasechar $idx $param - #cursor position doesn't change. - } - r { - #$re_decstbm - #https://www.vt100.net/docs/vt510-rm/DECSTBM.html - #This control function sets the top and bottom margins for the current page. You cannot perform scrolling outside the margins - lassign [split $param {;}] margin_top margin_bottom - - #todo - return these for the caller to process.. - puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" - #Also moves the cursor to col 1 line 1 of the page - set cursor_column 1 - set cursor_row 1 - - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move ;#own instruction? decstbm? - break - } - s { - # - todo - make ansi.sys CSI s cursor save only apply for certain cases? - may need to support DECSLRM instead which uses same code - - #$re_cursor_save - #cursor save could come after last column - if {$overflow_idx != -1 && $idx == $overflow_idx} { - #bartman2.ans test file - fixes misalignment at bottom of dialog bubble - #incr cursor_row - #set cursor_column 1 - #bwings1.ans test file - breaks if we actually incr cursor (has repeated saves) - set cursor_saved_position [list row [expr {$cursor_row+1}] column 1] - } else { - set cursor_saved_position [list row $cursor_row column $cursor_column] - } - #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. - #we need the SGR and gx overlay codes prior to the cursor_save - - #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. - #set sgr_stack [lindex $understacks $idx] - #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) - - set sgr_stack [list] - set gx_stack [list] - - #we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those. - #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. - - foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { - lassign $gc type code - #types g other sgr gx0 - switch -- $type { - gx0 { - #code is actually a stand-in for the graphics on/off code - not the raw code - #It is either gx0_on or gx0_off - set gx_stack [list $code] - } - sgr { - #code is the raw code - if {[punk::ansi::codetype::is_sgr_reset $code]} { - #jmn - set sgr_stack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set sgr_stack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #often we don't get resets - and codes just pile up. - #as a first step to simplifying - at least remove earlier straight up dupes - set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars) - set sgr_stack [lremove $sgr_stack {*}$dup_posns] - lappend sgr_stack $code - } - } - } - } - set cursor_saved_attributes "" - switch -- [lindex $gx_stack 0] { - gx0_on { - append cursor_saved_attributes "\x1b(0" - } - gx0_off { - append cursor_saved_attributes "\x1b(B" - } - } - #append cursor_saved_attributes [join $sgr_stack ""] - append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack] - - #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. - - #don't incr index - or the save will cause cursor to move to the right - #carry on - - } - u { - #$re_cursor_restore - #we are going to jump somewhere.. for now we will assume another line, and process accordingly. - #The caller has the cursor_saved_position/cursor_saved_attributes if any (?review - if we always pass it back it, we could save some calls for moves in same line) - #don't set overflow at this point. The existing underlay to the right must be preserved. - #we only want to jump and render the unapplied at the new location. - - #lset overstacks $idx_over [list] - #set replay_codes_overlay "" - - #if {$cursor_saved_attributes ne ""} { - # set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk - #} else { - #jj - #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set replay_codes_overlay "" - #} - - #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code - incr idx_over - - set unapplied "" - set unapplied_list [list] - foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { - lassign $gc type item - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - #incr idx_over - } - set unapplied [join $unapplied_list ""] - #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. - set instruction restore_cursor - break - } - ~ { - #$re_vt_sequence - #lassign $matchinfo _match key mod - lassign [split $param {;}] key mod - - #Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~ - # - #e.g esc \[2~ insert esc \[2;2~ shift-insert - #mod - subtract 1, and then use bitmask - #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) - #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" - if {$key eq "1"} { - #home - } elseif {$key eq "2"} { - #Insert - if {$mod eq ""} { - #no modifier key - set insert_mode [expr {!$insert_mode}] - #rather than set the cursor - we return the insert mode state so the caller can decide - } - } elseif {$key eq "3"} { - #Delete - presumably this shifts other chars in the line, with empty cells coming in from the end - switch -- $mod { - "" { - priv::render_delchar $idx - } - "5" { - #ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?) - } - } - } elseif {$key eq "4"} { - #End - } elseif {$key eq "5"} { - #pgup - } elseif {$key eq "6"} { - #pgDn - } elseif {$key eq "7"} { - #Home - #?? - set idx [expr {$opt_colstart -1}] - set cursor_column 1 - } elseif {$key eq "8"} { - #End - } elseif {$key eq "11"} { - #F1 - or ESCOP or e.g shift F1 ESC\[1;2P - } elseif {$key eq "12"} { - #F2 - or ESCOQ - } elseif {$key eq "13"} { - #F3 - or ESCOR - } elseif {$key eq "14"} { - #F4 - or ESCOS - } elseif {$key eq "15"} { - #F5 or shift F5 ESC\[15;2~ - } elseif {$key eq "17"} { - #F6 - } elseif {$key eq "18"} { - #F7 - } elseif {$key eq "19"} { - #F8 - } elseif {$key eq "20"} { - #F9 - } elseif {$key eq "21"} { - #F10 - } elseif {$key eq "23"} { - #F11 - } elseif {$key eq "24"} { - #F12 - } - - } - h - l { - #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? - - #$re_mode if first after CSI is "?" - #some docs mention ESC=h|l - not seen on windows terminals.. review - #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html - if {[tcl::string::index $codenorm 4] eq "?"} { - set num [tcl::string::range $codenorm 5 end-1] ;#param between ? and h|l - #lassign $matchinfo _match num type - switch -- $num { - 5 { - #DECSNM - reverse video - #How we simulate this to render within a block of text is an open question. - #track all SGR stacks and constantly flip based on the current SGR reverse state? - #It is the job of the calling loop to do this - so at this stage we'll just set the states - #DECAWM autowrap - if {$type eq "h"} { - #set (enable) - set reverse_mode 1 - } else { - #reset (disable) - set reverse_mode 0 - } - - } - 7 { - #DECAWM autowrap - if {$type eq "h"} { - #set (enable) - set autowrap_mode 1 - if {$opt_width ne "\uFFEF"} { - set overflow_idx $opt_width - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? presume not - but sanity check for now. - if {$idx >= $overflow_idx} { - puts stderr "renderline error - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" - } - } else { - #reset (disable) - set autowrap_mode 0 - set overflow_idx -1 - } - } - 25 { - if {$type eq "h"} { - #visible cursor - - } else { - #invisible cursor - - } - } - } - - } else { - puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - default { - puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - } - 7ESC { - #$re_other_single - switch -- [tcl::string::index $codenorm end] { - D { - #\x84 - #index (IND) - #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" - puts stderr "ESC D not fully implemented" - incr cursor_row - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction down - #retain cursor_column - break - } - M { - #\x8D - #Reverse Index (RI) - #vt102-docs: "Moves cursor up one line in same column. If cursor is at top margin, screen performs a scroll-down" - puts stderr "ESC M not fully implemented" - - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move up - incr cursor_row -1 - if {$cursor_row < 1} { - set cursor_row 1 - } - #ensure rest of *overlay* is emitted to remainder - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction up ;#need instruction for scroll-down? - #retain cursor_column - break - } - E { - #\x85 - #review - is behaviour different to lf? - #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL - #leave implementation until logic for is set in stone... still under review - #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. - # - #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" - puts stderr "ESC E unimplemented" - - } - default { - puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - - } - } - - #switch -regexp -matchvar matchinfo -- $code\ - #$re_mode { - #}\ - #default { - # puts stderr "overtype::renderline code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - #} - - } - default { - #don't need to handle sgr or gx0 types - #we have our sgr gx0 codes already in stacks for each overlay grapheme - } - } - } - - #-------- - if {$opt_overflow == 0} { - #need to truncate to the width of the original undertext - #review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? - #set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars - } - if {$overflow_idx == -1} { - #overflow was initially unlimited and hasn't been overridden - } else { - - } - #-------- - - - #coalesce and replay codestacks for outcols grapheme list - set outstring "" ;#output prior to overflow - set overflow_right "" ;#remainder after overflow point reached - set i 0 - set cstack [list] - set prevstack [list] - set prev_g0 [list] - #note overflow_idx may already have been set lower if we had a row move above due to \v or ANSI moves - set in_overflow 0 ;#used to stop char-width scanning once in overflow - if {$overflow_idx == 0} { - #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW - set in_overflow 1 - } - foreach ch $outcols { - #puts "---- [ansistring VIEW $ch]" - - set gxleader "" - if {$i < [llength $understacks_gx]} { - #set g0 [tcl::dict::get $understacks_gx $i] - set g0 [lindex $understacks_gx $i] - if {$g0 ne $prev_g0} { - if {$g0 eq [list "gx0_on"]} { - set gxleader "\x1b(0" - } else { - set gxleader "\x1b(B" - } - } - set prev_g0 $g0 - } else { - set prev_g0 [list] - } - - set sgrleader "" - if {$i < [llength $understacks]} { - #set cstack [tcl::dict::get $understacks $i] - set cstack [lindex $understacks $i] - if {$cstack ne $prevstack} { - if {[llength $prevstack] && ![llength $cstack]} { - #This reset is important e.g testfile fruit.ans - we get overhang on rhs without it. But why is cstack empty? - append sgrleader \033\[m - } else { - append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] - } - } - set prevstack $cstack - } else { - set prevstack [list] - } - - - - if {$in_overflow} { - if {$i == $overflow_idx} { - set 0 [lindex $understacks_gx $i] - set gxleader "" - if {$g0 eq [list "gx0_on"]} { - set gxleader "\x1b(0" - } elseif {$g0 eq [list "gx0_off"]} { - set gxleader "\x1b(B" - } - append overflow_right $gxleader - set cstack [lindex $understacks $i] - set sgrleader "" - #whether cstack is same or differs from previous char's stack - we must have an output at the start of the overflow_right - #if {[llength $prevstack] && ![llength $cstack]} { - # append sgrleader \033\[m - #} - append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] - append overflow_right $sgrleader - append overflow_right $ch - } else { - append overflow_right $gxleader - append overflow_right $sgrleader - append overflow_right $ch - } - } else { - if {$overflow_idx != -1 && $i+1 == $overflow_idx} { - #one before overflow - #will be in overflow in next iteration - set in_overflow 1 - if {[grapheme_width_cached $ch]> 1} { - #we overflowed with second-half of a double-width char - replace first-half with user-supplied exposition char (should be 1 wide) - set ch $opt_exposed1 - } - } - append outstring $gxleader - append outstring $sgrleader - if {$idx+1 < $cursor_column} { - append outstring [tcl::string::map {\u0000 " "} $ch] - } else { - append outstring $ch - } - } - incr i - } - #flower.ans good test for null handling - reverse line building - if {![ansistring length $overflow_right]} { - set outstring [tcl::string::trimright $outstring "\u0000"] - } - set outstring [tcl::string::map {\u0000 " "} $outstring] - set overflow_right [tcl::string::trimright $overflow_right "\u0000"] - set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] - - set replay_codes "" - if {[llength $understacks] > 0} { - if {$overflow_idx == -1} { - #set tail_idx [tcl::dict::size $understacks] - set tail_idx [llength $understacks] - } else { - set tail_idx [llength $undercols] - } - if {$tail_idx-1 < [llength $understacks]} { - #set replay_codes [join [lindex $understacks $tail_idx-1] ""] ;#tail replay codes - set replay_codes [punk::ansi::codetype::sgr_merge_list {*}[lindex $understacks $tail_idx-1]] ;#tail replay codes - } - if {$tail_idx-1 < [llength $understacks_gx]} { - set gx0 [lindex $understacks_gx $tail_idx-1] - if {$gx0 eq [list "gx0_on"]} { - #if it was on, turn gx0 off at the point we stop processing overlay - append outstring "\x1b(B" - } - } - } - if {[string length $overflow_right]} { - #puts stderr "remainder:$overflow_right" - } - #pdict $understacks - - if {[punk::ansi::ta::detect_sgr $outstring]} { - append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column - - #close off any open gx? - #probably should - and overflow_right reopen? - } - - if {$opt_returnextra} { - #replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review - #replay_codes_underlay is the set of codes in effect at the very end of the original underlay - - #review - #replay_codes_overlay is the set of codes in effect at the very end of the original overlay (even if not all overlay was applied) - #todo - replay_codes for gx0 mode - - #overflow_idx may change during ansi & character processing - if {$overflow_idx == -1} { - set overflow_right_column "" - } else { - set overflow_right_column [expr {$overflow_idx+1}] - } - set result [tcl::dict::create\ - result $outstring\ - visualwidth [punk::ansi::printing_length $outstring]\ - instruction $instruction\ - stringlen [string length $outstring]\ - overflow_right_column $overflow_right_column\ - overflow_right $overflow_right\ - unapplied $unapplied\ - unapplied_list $unapplied_list\ - insert_mode $insert_mode\ - autowrap_mode $autowrap_mode\ - insert_lines_above $insert_lines_above\ - insert_lines_below $insert_lines_below\ - cursor_saved_position $cursor_saved_position\ - cursor_saved_attributes $cursor_saved_attributes\ - cursor_column $cursor_column\ - cursor_row $cursor_row\ - opt_overflow $opt_overflow\ - replay_codes $replay_codes\ - replay_codes_underlay $replay_codes_underlay\ - replay_codes_overlay $replay_codes_overlay\ - ] - if {$opt_returnextra == 1} { - return $result - } else { - #human/debug - map special chars to visual glyphs - set viewop VIEW - switch -- $opt_returnextra { - 2 { - #codes and character data - set viewop VIEWCODES ;#ansi colorisation of codes - green for SGR, blue/blue reverse for cursor_save/cursor_restore, cyan for movements, orange for others - } - 3 { - set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. - } - } - tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] - tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] - tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]] - tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] - tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] - tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] - tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] - tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] - return $result - } - } else { - return $outstring - } - #return [join $out ""] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace overtype ---}] -} - -tcl::namespace::eval overtype::piper { - proc overcentre {args} { - if {[llength $args] < 2} { - error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} - } - lassign [lrange $args end-1 end] over under - set argsflags [lrange $args 0 end-2] - tailcall overtype::centre {*}$argsflags $under $over - } - proc overleft {args} { - if {[llength $args] < 2} { - error {usage: ?-startcolumn ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} - } - lassign [lrange $args end-1 end] over under - set argsflags [lrange $args 0 end-2] - tailcall overtype::left {*}$argsflags $under $over - } -} - - -# -- --- --- --- --- --- --- --- --- --- --- -proc overtype::transparentline {args} { - foreach {under over} [lrange $args end-1 end] break - set argsflags [lrange $args 0 end-2] - set defaults [tcl::dict::create\ - -transparent 1\ - -exposed 1 " "\ - -exposed 2 " "\ - ] - set newargs [tcl::dict::merge $defaults $argsflags] - tailcall overtype::renderline {*}$newargs $under $over -} -#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. -# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. -#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. -# -tcl::namespace::eval overtype::piper { - proc renderline {args} { - if {[llength $args] < 2} { - error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? overtext pipelinedata} - } - foreach {over under} [lrange $args end-1 end] break - set argsflags [lrange $args 0 end-2] - tailcall overtype::renderline {*}$argsflags $under $over - } -} -interp alias "" piper_renderline "" overtype::piper::renderline - -#intended for single grapheme - but will work for multiple -#cannot contain ansi or newlines -#(a cache of ansifreestring_width calls - as these are quite regex heavy) -proc overtype::grapheme_width_cached {ch} { - variable grapheme_widths - if {[tcl::dict::exists $grapheme_widths $ch]} { - return [tcl::dict::get $grapheme_widths $ch] - } - set width [punk::char::ansifreestring_width $ch] - tcl::dict::set grapheme_widths $ch $width - return $width -} - - - -proc overtype::test_renderline {} { - set t \uFF5E ;#2-wide tilde - set u \uFF3F ;#2-wide underscore - set missing \uFFFD - return [list $t $u A${t}B] -} - -#maintenance warning -#same as textblock::size - but we don't want that circular dependency -#block width and height can be tricky. e.g \v handled differently on different terminal emulators and can affect both -proc overtype::blocksize {textblock} { - if {$textblock eq ""} { - return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings - } - if {[tcl::string::first \t $textblock] >= 0} { - if {[info exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - #stripansi on entire block in one go rather than line by line - result should be the same - review - make tests - if {[punk::ansi::ta::detect $textblock]} { - set textblock [punk::ansi::stripansi $textblock] - } - if {[tcl::string::last \n $textblock] >= 0} { - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map {\n {}} $textblock]]}] ;#faster than splitting into single-char list - set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } else { - set num_le 0 - set width [punk::char::ansifreestring_width $textblock] - } - #our concept of block-height is likely to be different to other line-counting mechanisms - set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - - return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize ]] width height -} - -tcl::namespace::eval overtype::priv { - variable cache_is_sgr [tcl::dict::create] - - #we are likely to be asking the same question of the same ansi codes repeatedly - #caching the answer saves some regex expense - possibly a few uS to lookup vs under 1uS - #todo - test if still worthwhile after a large cache is built up. (limit cache size?) - proc is_sgr {code} { - variable cache_is_sgr - if {[tcl::dict::exists $cache_is_sgr $code]} { - return [tcl::dict::get $cache_is_sgr $code] - } - set answer [punk::ansi::codetype::is_sgr $code] - tcl::dict::set cache_is_sgr $code $answer - return $answer - } - proc render_unapplied {overlay_grapheme_control_list gci} { - upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split - upvar overstacks overstacks - upvar overstacks_gx overstacks_gx - upvar overlay_grapheme_control_stacks og_stacks - - #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] - #append unapplied [join [lindex $overstacks $idx_over] ""] - #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] - set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] - if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged - } - switch -- [lindex $overstacks_gx $idx_over] { - "gx0_on" { - lappend unapplied_list "\x1b(0" - } - "gx0_off" { - lappend unapplied_list "\x1b(B" - } - } - - foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { - lassign $gc type item - #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - } - set unapplied [join $unapplied_list ""] - } - - #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack - proc render_this_unapplied {overlay_grapheme_control_list gci} { - upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list - upvar overstacks overstacks - upvar overstacks_gx overstacks_gx - upvar overlay_grapheme_control_stacks og_stacks - - #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] - - set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] - if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged - } - switch -- [lindex $overstacks_gx $idx_over] { - "gx0_on" { - lappend unapplied_list "\x1b(0" - } - "gx0_off" { - lappend unapplied_list "\x1b(B" - } - } - - foreach gc [lrange $overlay_grapheme_control_list $gci end] { - lassign $gc type item - #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - } - set unapplied [join $unapplied_list ""] - } - proc render_delchar {i} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - set nxt [llength $o] - if {$i < $nxt} { - set o [lreplace $o $i $i] - set ustacks [lreplace $ustacks $i $i] - set gxstacks [lreplace $gxstacks $i $i] - } else { - - } - } - proc render_erasechar {i count} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - #ECH clears character attributes from erased character positions - #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller should do that mapping and only supply 1 or greater. - if {![tcl::string::is integer -strict $count] || $count < 1} { - error "render_erasechar count must be integer >= 1" - } - set start $i - set end [expr {$i + $count -1}] - #we restrict ECH to current line - as some terminals do - review - is that the only way it's implemented? - if {$i > [llength $o]-1} { - return - } - if {$end > [llength $o]-1} { - set end [expr {[llength $o]-1}] - } - set num [expr {$end - $start + 1}] - set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space? - set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list]]] - set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] - return - } - proc render_setchar {i c } { - upvar outcols o - lset o $i $c - } - #is actually addgrapheme? - proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - - if 0 { - if {$c eq "c"} { - puts "i:$i c:$c sgrstack:[ansistring VIEW $sgrstack]" - puts "understacks:[ansistring VIEW $ustacks]" - upvar overstacks overstacks - puts "overstacks:[ansistring VIEW $overstacks]" - puts "info level 0:[info level 0]" - } - } - - set nxt [llength $o] - if {!$insert_mode} { - if {$i < $nxt} { - #These lists must always be in sync - lset o $i $c - } else { - lappend o $c - } - if {$i < [llength $ustacks]} { - lset ustacks $i $sgrstack - lset gxstacks $i $gx0stack - } else { - lappend ustacks $sgrstack - lappend gxstacks $gx0stack - } - } else { - #insert of single-width vs double-width when underlying is double-width? - if {$i < $nxt} { - set o [linsert $o $i $c] - } else { - lappend o $c - } - if {$i < [llength $ustacks]} { - set ustacks [linsert $ustacks $i $sgrstack] - set gxstacks [linsert $gxstacks $i $gx0stack] - } else { - lappend ustacks $sgrstack - lappend gxstacks $gx0stack - } - } - } - -} - - - -# -- --- --- --- --- --- --- --- --- --- --- -tcl::namespace::eval overtype { - interp alias {} ::overtype::center {} ::overtype::centre -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide overtype [tcl::namespace::eval overtype { - variable version - set version 1.6.4 -}] -return - -#*** !doctools -#[manpage_end]