diff --git a/src/bootsupport/modules/include_modules.config b/src/bootsupport/modules/include_modules.config index 490025b..75a091d 100644 --- a/src/bootsupport/modules/include_modules.config +++ b/src/bootsupport/modules/include_modules.config @@ -57,6 +57,7 @@ set bootsupport_modules [list\ modules punk::path\ modules punk::repo\ modules punk::tdl\ + modules punk::zip\ modules punk::winpath\ modules textblock\ modules oolib\ diff --git a/src/bootsupport/modules/overtype-1.6.5.tm b/src/bootsupport/modules/overtype-1.6.5.tm index f7e4c1a..38ce71c 100644 --- a/src/bootsupport/modules/overtype-1.6.5.tm +++ b/src/bootsupport/modules/overtype-1.6.5.tm @@ -165,16 +165,17 @@ tcl::namespace::eval overtype::priv { #could return larger than renderwidth proc _get_row_append_column {row} { + #obsolete? upvar outputlines outputlines set idx [expr {$row -1}] if {$row <= 1 || $row > [llength $outputlines]} { return 1 } else { - upvar opt_overflow opt_overflow + upvar opt_expand_right expand_right upvar renderwidth renderwidth set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] set endpos [expr {$existinglen +1}] - if {$opt_overflow} { + if {$expand_right} { return $endpos } else { if {$endpos > $renderwidth} { @@ -204,14 +205,14 @@ tcl::namespace::eval overtype { 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 + #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [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: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} } set optargs [lrange $args 0 end-2] if {[llength $optargs] % 2 == 0} { @@ -228,30 +229,46 @@ tcl::namespace::eval overtype { } } set opts [tcl::dict::create\ - -bias ignored\ - -width \uFFEF\ - -height \uFFEF\ + -bias ignored\ + -width \uFFEF\ + -height \uFFEF\ -startcolumn 1\ - -wrap 0\ - -ellipsis 0\ + -wrap 0\ + -ellipsis 0\ -ellipsistext $default_ellipsis_horizontal\ -ellipsiswhitespace 0\ - -overflow 0\ - -appendlines 1\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -experimental 0\ - -looplimit \uFFEF\ - -crm_mode 0\ - -reverse_mode 0\ + -expand_right 0\ + -appendlines 1\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -experimental 0\ + -cp437 1\ + -looplimit \uFFEF\ + -crm_mode 0\ + -reverse_mode 0\ + -insert_mode 0\ + -console {stdin stdout stderr}\ ] + #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. + # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) + # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. + # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. + # - further implication is that if expand_right grows the virtual renderspace terminal width - + # then some sort of reflow/rerender needs to be done for preceeding lines? + # possibly not - as expand_right is distinct from a normal terminal-width change event, + # expand_right being primarily to support other operations such as textblock::table + + #todo - viewport width/height as separate concept to terminal width/height? #-ellipsis args not used if -wrap is true foreach {k v} $argsflags { switch -- $k { - -looplimit - -width - -height - -startcolumn - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -appendlines + -looplimit - -width - -height - -startcolumn - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -transparent - -exposed1 - -exposed2 - -experimental - - -reverse_mode - -crm_mode { + - -expand_right - -appendlines + - -reverse_mode - -crm_mode - -insert_mode + - -cp437 + - -console { tcl::dict::set opts $k $v } default { @@ -261,7 +278,8 @@ tcl::namespace::eval overtype { } #set opts [tcl::dict::merge $defaults $argsflags] # -- --- --- --- --- --- - set opt_overflow [tcl::dict::get $opts -overflow] + #review - expand_left for RTL text? + set opt_expand_right [tcl::dict::get $opts -expand_right] ##### # 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) @@ -279,23 +297,31 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- set opt_crm_mode [tcl::dict::get $opts -crm_mode] set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] + set opt_insert_mode [tcl::dict::get $opts -insert_mode] + # -- --- --- --- --- --- + set opt_cp437 [tcl::dict::get $opts -cp437] + + + #initial state for renderspace 'terminal' reset + set initial_state [dict create\ + -width $opt_width\ + -height $opt_height\ + -crm_mode $opt_crm_mode\ + -reverse_mode $opt_reverse_mode\ + -insert_mode $opt_insert_mode\ + -cp437 $opt_cp437\ + ] # ---------------------------- # -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 { @@ -309,11 +335,10 @@ tcl::namespace::eval overtype { } } } - 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 insert_mode $opt_insert_mode ;#can be toggled by insert key or ansi IRM sequence ESC [ 4 h|l set autowrap_mode $opt_wrap set reverse_mode $opt_reverse_mode set crm_mode $opt_crm_mode @@ -377,49 +402,45 @@ tcl::namespace::eval overtype { 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] + 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 } - 1 { - set inputchunks [punk::ansi::ta::split_codes $overblock] + } + 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 } - 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 - } + if {[llength $lflines]} { + lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] } - 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] + set inputchunks $lflines[unset lflines] - } } } @@ -441,11 +462,11 @@ tcl::namespace::eval overtype { #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 { + #if {$data_mode} { + # set col [_get_row_append_column $row] + #} else { set col $opt_startcolumn - } + #} set instruction_stats [tcl::dict::create] @@ -473,33 +494,27 @@ tcl::namespace::eval overtype { } #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\ - -crm_mode $crm_mode\ - -autowrap_mode $autowrap_mode\ - -reverse_mode $reverse_mode\ - -transparent $opt_transparent\ - -width $renderwidth\ - -exposed1 $opt_exposed1\ - -exposed2 $opt_exposed2\ - -overflow $opt_overflow -cursor_column $col -cursor_row $row $undertext $overtext] - set rinfo [renderline -experimental $opt_experimental\ + set renderargs [list -experimental $opt_experimental\ + -cp437 $opt_cp437\ -info 1\ -crm_mode $crm_mode\ -insert_mode $insert_mode\ -autowrap_mode $autowrap_mode\ - -reverse_mode $reverse_mode\ + -reverse_mode $reverse_mode\ -cursor_restore_attributes $cursor_saved_attributes\ -transparent $opt_transparent\ -width $renderwidth\ -exposed1 $opt_exposed1\ -exposed2 $opt_exposed2\ - -overflow $opt_overflow\ + -expand_right $opt_expand_right\ -cursor_column $col\ -cursor_row $row\ $undertext\ $overtext\ - ] + ] + set LASTCALL $renderargs + set rinfo [renderline {*}$renderargs] + 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] ;# @@ -523,6 +538,7 @@ tcl::namespace::eval overtype { #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] if {0 && $reverse_mode} { + #test branch - todo - prune puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" #review #JMN3 @@ -579,29 +595,17 @@ tcl::namespace::eval overtype { #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 > $renderwidth} { + reset { + #reset the 'renderspace terminal' (not underlying terminal) + set row 1 + set col 1 - } - } 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 - #} - } + } + {} { + #lf included in data + set row $post_render_row + set col $post_render_col } up { @@ -704,7 +708,14 @@ tcl::namespace::eval overtype { puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" - set sub_info [overtype::renderline -info 1 -width $renderwidth -insert_mode $insert_mode -autowrap_mode $autowrap_mode -overflow [tcl::dict::get $opts -overflow] "" $overflow_right] + set sub_info [overtype::renderline -info 1\ + -width $renderwidth\ + -insert_mode $insert_mode\ + -autowrap_mode $autowrap_mode\ + -expand_right [tcl::dict::get $opts -opt_expand_right]\ + ""\ + $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.. @@ -735,7 +746,7 @@ tcl::namespace::eval overtype { #overflow + unapplied? } lf_start { - #raw newlines - must be test_mode + #raw newlines # ---------------------- #test with fruit.ans #test - treating as newline below... @@ -751,48 +762,58 @@ tcl::namespace::eval overtype { } 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 edit_mode 0 + if {$edit_mode} { + set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] set overflow_right "" - - - set row $renderedrow - + set unapplied "" + set row $post_render_row + #set col $post_render_col 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 "" + if 1 { + if {$overflow_right ne ""} { + if {$opt_expand_right} { + append rendered $overflow_right + set overflow_right "" + } else { + set overflow_width [punk::ansi::printing_length $overflow_right] + if {$visualwidth + $overflow_width <= $renderwidth} { + append rendered $overflow_right + set overflow_right "" + } else { + if {$visualwidth < $renderwidth} { + set graphemes [punk::char::grapheme_split $overflow_width] + set add "" + set addlen $visualwidth + set remaining_overflow $graphemes + foreach g $graphemes { + set w [overtype::grapheme_width_cached] + if {$addlen + $w <= $renderwidth} { + append add $g + incr addlen $w + lpop remaining_overflow + } else { + break + } + } + append rendered $add + set overflow_right [join $remaining_overflow ""] + } + } + } + } set row $post_render_row - #set col $post_render_col set col $opt_startcolumn if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } } else { + #old version - known to work with various ansi graphics - e.g fruit.ans + # - but fails to limit lines to renderwidth when expand_right == 0 append rendered $overflow_right set overflow_right "" set row $post_render_row @@ -851,38 +872,28 @@ tcl::namespace::eval overtype { 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 + #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 @@ -974,7 +985,6 @@ tcl::namespace::eval overtype { 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] @@ -1052,7 +1062,7 @@ tcl::namespace::eval overtype { } - if {!$opt_overflow && !$autowrap_mode} { + if {!$opt_expand_right && !$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 @@ -1130,7 +1140,6 @@ tcl::namespace::eval overtype { 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" @@ -1433,7 +1442,7 @@ tcl::namespace::eval overtype { #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 rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $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] @@ -1584,7 +1593,7 @@ tcl::namespace::eval overtype { set overflowlength [expr {$overtext_datalen - $renderwidth}] 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 rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -expand_right $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] @@ -1632,8 +1641,8 @@ tcl::namespace::eval overtype { } 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] + #Note - we still need expand_right 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 -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] #puts stderr "--> [ansistring VIEW -lf 1 -nul 1 $rinfo] <--" set overflow_right [tcl::dict::get $rinfo overflow_right] set unapplied [tcl::dict::get $rinfo unapplied] @@ -1655,7 +1664,8 @@ tcl::namespace::eval overtype { #-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) + #(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? + # This would probably be impractical to support for different fonts) #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} { @@ -1677,8 +1687,10 @@ tcl::namespace::eval overtype { #[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. + #puts stderr "renderline '$args'" + if {[llength $args] < 2} { - error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-overflow [1|0]? undertext overtext} + error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} } lassign [lrange $args end-1 end] under over if {[string first \n $under] >= 0} { @@ -1692,7 +1704,7 @@ tcl::namespace::eval overtype { set opts [tcl::dict::create\ -etabs 0\ -width \uFFEF\ - -overflow 0\ + -expand_right 0\ -transparent 0\ -startcolumn 1\ -cursor_column 1\ @@ -1713,13 +1725,13 @@ tcl::namespace::eval overtype { #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 + #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency, currsor movements to 2nd charcol, or overflow/expand_right #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 + -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { tcl::dict::set opts $k $v @@ -1732,7 +1744,7 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- --- --- --- --- 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_expand_right [tcl::dict::get $opts -expand_right] 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] @@ -1752,17 +1764,7 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- --- --- --- --- 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] @@ -1852,7 +1854,7 @@ tcl::namespace::eval overtype { 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 pt_underchars "" ;#for string_columns length calculation for expand_right 0 truncation set remainder [list] ;#for returnextra foreach {pt code} $undermap { #pt = plain text @@ -1996,47 +1998,25 @@ tcl::namespace::eval overtype { #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] - } - } + #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] } - } 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 {[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 renderwidth $opt_width } else { @@ -2127,8 +2107,10 @@ tcl::namespace::eval overtype { lappend overlay_grapheme_control_stacks $o_codestack } } else { + set tsbegin [clock micros] foreach grapheme_original [punk::char::grapheme_split $pt] { set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] + #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" foreach grapheme [punk::char::grapheme_split $pt_crm] { if {$grapheme eq "\n"} { lappend overlay_grapheme_control_stacks $o_codestack @@ -2142,6 +2124,8 @@ tcl::namespace::eval overtype { } } } + set elapsed [expr {[clock micros] - $tsbegin}] + puts stderr "ptlen [string length $pt] elapsedus:$elapsed" } #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc @@ -2259,11 +2243,12 @@ tcl::namespace::eval overtype { # -- --- --- #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. + if {$opt_expand_right} { + #expand_right 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. + #we currently only support horizontal expansion to the right (review regarding RTL text!) set overflow_idx -1 } else { - #overflow zero - we can't grow beyond our column width - so we get ellipsis or truncation + #expand_right 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 { @@ -2304,7 +2289,7 @@ tcl::namespace::eval overtype { #movements only occur within the overlay range. #an underlay is however not necessary.. e.g - #renderline -overflow 1 "" data + #renderline -expand_right 1 "" data #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} @@ -2331,7 +2316,7 @@ tcl::namespace::eval overtype { g { set ch $item #crm_mode affects both graphic and control - if {$crm_mode} { + if {0 && $crm_mode} { set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] set chars [string map [list \n "\x1b\[00001E"] $chars] if {[llength [split $chars ""]] > 1} { @@ -2376,7 +2361,7 @@ tcl::namespace::eval overtype { #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 overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 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 @@ -2384,7 +2369,10 @@ tcl::namespace::eval overtype { #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 + if {$idx == -1 || $overflow_idx > $idx} { + #don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 + } set instruction lf_mid priv::render_unapplied $overlay_grapheme_control_list $gci break @@ -2466,23 +2454,35 @@ tcl::namespace::eval overtype { #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 + #REVIEW + set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control + lassign $next_gc next_type next_item + if {$autowrap_mode || $next_type ne "g"} { + 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 { + #no point throwing back to caller for each grapheme that is overflowing + #without this branch - renderline would be called with overtext reducing only by one grapheme per call + #processing a potentially long overtext each time (ie - very slow) + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #JMN4 + + } } } 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) + #overflow_idx = -1 + #This corresponds to expand_right 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])} { + 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 " " @@ -2621,7 +2621,7 @@ tcl::namespace::eval overtype { } incr idx } - if {($cursor_column < [llength $outcols]) || $overflow_idx == -1 || $test_mode} { + if {($cursor_column < [llength $outcols]) || $overflow_idx == -1} { incr cursor_column } } elseif {$uwidth > 1} { @@ -2655,12 +2655,6 @@ tcl::namespace::eval overtype { 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] - } - } } } } @@ -2704,6 +2698,7 @@ tcl::namespace::eval overtype { set leadernorm [tcl::string::range [tcl::string::map [list\ \x1b\[< 1006\ \x1b\[ 7CSI\ + \x1bP 7DCS\ \x9b 8CSI\ \x1b\] 7OSC\ \x9d 8OSC\ @@ -2720,6 +2715,11 @@ tcl::namespace::eval overtype { 7CSI - 7OSC { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] } + 7DCS { + #ESC P + #Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74 + 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]] } @@ -2812,7 +2812,7 @@ tcl::namespace::eval overtype { if {$overflow_idx == -1} { incr max } - if {$test_mode && $cursor_column == $max+1} { + if {$cursor_column == $max+1} { #move_forward while in overflow incr cursor_column -1 } @@ -2829,7 +2829,7 @@ tcl::namespace::eval overtype { } #horizontal movement beyond line extent needs to wrap - throw back to caller - #we may have both overflow_rightand unapplied data + #we may have both overflow_right and 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 @@ -2844,7 +2844,8 @@ tcl::namespace::eval overtype { } } } else { - if {!$opt_overflow || ($cursor_column + $num) <= [llength $outcols+1]} { + #review - dead branch + if {!$expand_right || ($cursor_column + $num) <= [llength $outcols+1]} { incr idx $num incr cursor_column $num } else { @@ -3052,55 +3053,99 @@ tcl::namespace::eval overtype { } } J { - puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of screen - } - 1 { - #clear from cursor to beginning of screen - } - 2 { - #clear entire screen - #ansi.sys - move cursor to upper left REVIEW - set cursor_row 1 - set cursor_column 1 - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - } - 3 { - #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? - + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + #CSI ? Pn J - selective erase + puts stderr "overtype::renderline ED - SELECTIVE ERASE IN DISPLAY (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" } default { + puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of screen + } + 1 { + #clear from cursor to beginning of screen + } + 2 { + #clear entire screen + #ansi.sys - move cursor to upper left REVIEW + set cursor_row 1 + set cursor_column 1 + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + } + 3 { + #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? + + } + default { + } + } + } } - } K { - puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of line - } - 1 { - #clear from cursor to beginning of line + #see DECECM regarding background colour + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param [string range $param 1 end] ;#chop qmark + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line - depending on DECSCA + } + 1 { + #clear from cursor to beginning of line - depending on DECSCA + + } + 2 { + #clear entire line - depending on DECSCA + } + default { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } - } - 2 { - #clear entire line } default { - puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line + } + 1 { + #clear from cursor to beginning of line + + } + 2 { + #clear entire line + } + default { + puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } } } } + L { + puts stderr "overtype::renderline IL - Insert Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + M { + #CSI Pn M - DL - Delete Line + puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + } X { puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param" #ECH - erase character @@ -3108,6 +3153,36 @@ tcl::namespace::eval overtype { priv::render_erasechar $idx $param #cursor position doesn't change. } + q { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + {"} { + #DECSCA - Select Character Protection Attribute + #(for use with selective erase: DECSED and DECSEL) + set param [tcl::string::range $codenorm 4 end-2] + if {$param eq ""} {set param 0} + #TODO - store like SGR in stacks - replays? + switch -exact -- $param { + 0 - 2 { + #canerase + puts stderr "overtype::renderline - DECSCA canerase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 1 { + #cannoterase + puts stderr "overtype::renderline - DECSCA cannoterase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline DECSCA param '$param' not understood [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + puts stderr "overtype::renderline - CSI ... q not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } r { #$re_decstbm #https://www.vt100.net/docs/vt510-rm/DECSTBM.html @@ -3279,72 +3354,97 @@ tcl::namespace::eval overtype { set instruction restore_cursor break } + "{" { + + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + "}" { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + ' { + puts stderr "renderline warning - DECIC - Insert Column - CSI...' - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + default { + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + } + } ~ { - #$re_vt_sequence - 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 + set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ + switch -exact -- $code_secondlast { + ' { + #DECDC - editing sequence - Delete Column + puts stderr "renderline warning - DECDC - unimplemented" } - } 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(?) + default { + #$re_vt_sequence + 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 } + } - } 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 } } @@ -3358,51 +3458,72 @@ tcl::namespace::eval overtype { set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = switch -exact -- $modegroup { ? { - set num [tcl::string::range $codenorm 5 end-1] ;#param between ? and h|l - 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 - - if {$code_end eq "h"} { - #set (enable) - set reverse_mode 1 - } else { - #reset (disable) - set reverse_mode 0 + set smparams [tcl::string::range $codenorm 5 end-1] ;#params between ? and h|l + #one or more modes can be set + set smparam_list [split $smparams {;}] + foreach num $smparam_list { + switch -- $num { + "" { + #ignore empties e.g extra/trailing semicolon in params } - - } - 7 { - #DECAWM autowrap - if {$code_end eq "h"} { - #set (enable) - set autowrap_mode 1 - if {$opt_width ne "\uFFEF"} { - set overflow_idx $opt_width + 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 + + if {$code_end eq "h"} { + #set (enable) + set reverse_mode 1 } 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 + #reset (disable) + set reverse_mode 0 } - #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" + + } + 7 { + #DECAWM autowrap + if {$code_end 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 usually - but sanity check with warning for now. + if {$idx >= $overflow_idx} { + puts stderr "renderline warning - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" + } + } else { + #reset (disable) + set autowrap_mode 0 + #REVIEW! + set overflow_idx -1 } - } else { - #reset (disable) - set autowrap_mode 0 - set overflow_idx -1 } - } - 25 { - if {$code_end eq "h"} { - #visible cursor + 25 { + if {$code_end eq "h"} { + #visible cursor - } else { - #invisible cursor + } else { + #invisible cursor + } + } + 117 { + #DECECM - Erase Color Mode + #https://invisible-island.net/ncurses/ncurses.faq.html + #The Erase color selection controls the background color used when text is erased or new + #text is scrolled on to the screen. Screen background causes newly erased areas or + #scrolled text to be written using color index zero, the screen background. This is VT + #and DECterm compatible. Text background causes erased areas or scrolled text to be + #written using the current text background color. This is PC console compatible and is + #the factory default. + + #see also: https://unix.stackexchange.com/questions/251726/clear-to-end-of-line-uses-the-wrong-background-color-in-screen } } } @@ -3422,8 +3543,21 @@ tcl::namespace::eval overtype { # #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 #https://vt100.net/docs/vt510-rm/CRM.html + #NOTE - vt100 CRM always does auto-wrap at right margin. + #disabling auto-wrap in set-up or by sequence is disabled. + #We should default to turning off auto-wrap when crm_mode enabled.. but + #displaying truncated (on rhs) crm can still be very useful - and we have optimisation in overflow to avoid excess renderline calls (per grapheme) + #we therefore could reasonably put in an exception to allow auto_wrap to be disabled after crm_mode is engaged, + #although this would be potentially an annoying difference to some.. REVIEW if {$code_end eq "h"} { set crm_mode 1 + 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 + } } else { set crm_mode 0 } @@ -3431,8 +3565,10 @@ tcl::namespace::eval overtype { 4 { #IRM - Insert/Replace Mode if {$code_end eq "h"} { + #CSI 4 h set insert_mode 1 } else { + #CSI 4 l #replace mode set insert_mode 0 } @@ -3480,25 +3616,49 @@ tcl::namespace::eval overtype { } } 7ESC { + # #re_other_single {\x1b(D|M|E)$} #also PM \x1b^...(ST) switch -- [tcl::string::index $codenorm 4] { + c { + #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! + puts stderr "renderline reset" + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction reset + break + } 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" + puts stderr "renderline ESC D not fully implemented" incr cursor_row priv::render_unapplied $overlay_grapheme_control_list $gci set instruction 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 "overtype::renderline ESC E unimplemented" + + } + H { + #\x88 + #Tab Set + puts stderr "overtype::renderline ESC H tab set unimplemented" + } 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" + puts stderr "overtype::renderline ESC M not fully implemented" set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #move up @@ -3512,17 +3672,39 @@ tcl::namespace::eval overtype { #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" + N { + #\x8e - affects next character only + puts stderr "overtype::renderline single shift select G2 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + O { + #\x8f - affects next character only + puts stderr "overtype::renderline single shift select G3 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + P { + #\x90 + #DCS - shouldn't get here - handled in 7DCS branch + #similarly \] OSC (\x9d) and \\ (\x9c) ST + } + V { + #\x96 } + W { + #\x97 + } + X { + #\x98 + #SOS + if {[string index $code end] eq "\007"} { + set sos_content [string range $code 2 end-1] ;#ST is \007 + } else { + set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ + } + #return in some useful form to the caller + #TODO! + lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] + puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } ^ { #puts stderr "renderline PM" #Privacy Message. @@ -3550,24 +3732,6 @@ tcl::namespace::eval overtype { #lappend to a dict element in the result for application-specific processing lappend pm_list $pm_content } - N - O { - puts stderr "overtype::renderline single shift command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - P { - puts stderr "overtype::renderline DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - X { - #SOS - if {[string index $code end] eq "\007"} { - set sos_content [string range $code 2 end-1] ;#ST is \007 - } else { - set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ - } - #return in some useful form to the caller - #TODO! - lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] - puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } _ { #APC Application Program Command #just warn for now.. @@ -3578,6 +3742,14 @@ tcl::namespace::eval overtype { } } + } + 7DCS { + puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + # + + } + 7OSC - 8OSC { + } default { } @@ -3593,7 +3765,7 @@ tcl::namespace::eval overtype { } #-------- - if {$opt_overflow == 0} { + if {$opt_expand_right == 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 @@ -3774,13 +3946,14 @@ tcl::namespace::eval overtype { cursor_saved_attributes $cursor_saved_attributes\ cursor_column $cursor_column\ cursor_row $cursor_row\ - opt_overflow $opt_overflow\ + expand_right $opt_expand_right\ replay_codes $replay_codes\ replay_codes_underlay $replay_codes_underlay\ replay_codes_overlay $replay_codes_overlay\ pm_list $pm_list\ ] if {$opt_returnextra == 1} { + #puts stderr "renderline: $result" return $result } else { #human/debug - map special chars to visual glyphs @@ -3805,6 +3978,7 @@ tcl::namespace::eval overtype { return $result } } else { + #puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right" return $outstring } #return [join $out ""] diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index 7a2f944..267e680 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -106,7 +106,7 @@ tcl::namespace::eval punk::ansi::class { #overflow is a different concept - perhaps not particularly congruent with the idea of the textblock as a mini terminal emulator. #overflow effectively auto-expands the block(terminal?) width #overflow and wrap both being true won't make sense unless we implement a max_overflow concept - set o_rendered [overtype::renderspace -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] + set o_rendered [overtype::renderspace -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] if {$cksum eq "not-done"} { #if dimensions changed - the checksum won't have been done set o_rendered_what [$o_ansistringobj checksum] @@ -129,7 +129,7 @@ tcl::namespace::eval punk::ansi::class { set o_dimensions $dimensions - set rendered [overtype::renderspace -experimental {test_mode} -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] + set rendered [overtype::renderspace -cp437 1 -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] return $rendered } method render_to_input_line {args} { @@ -176,7 +176,7 @@ tcl::namespace::eval punk::ansi::class { if {$opt_minus ne "0"} { set chunk [tcl::string::range $chunk 0 end-$opt_minus] } - set rendered [overtype::renderspace -experimental {test_mode} -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk] + set rendered [overtype::renderspace -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk] set marker "" for {set i 1} {$i <= $w} {incr i} { if {$i % 10 == 0} { @@ -514,11 +514,8 @@ tcl::namespace::eval punk::ansi { set encnames [encoding names] set encoding "" set dimensions "" - set test_mode 0 foreach a $args { - if {$a eq "test_mode"} { - set test_mode 1 - } elseif {$a in $encnames} { + if {$a in $encnames} { set encoding $a } else { if {[regexp {[0-9]+(?:x|X)[0-9]+} $a]} { diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index 6368aea..4dd7bd6 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -1021,8 +1021,8 @@ namespace eval punk::console { #It's known this isn't always the case - but things like textutil::untabify2 take only a single value #on some systems test_char_width is a similar speed to get_tabstop_apparent_width - but on some test_char_width is much slower #we will use test_char_width as a fallback - proc get_tabstop_apparent_width {} { - set tslist [get_tabstops] + proc get_tabstop_apparent_width {{inoutchannels {stdin stdout}}} { + set tslist [get_tabstops $inoutchannels] if {![llength $tslist]} { #either terminal failed to report - or none set. set testw [test_char_width \t] @@ -1199,7 +1199,7 @@ namespace eval punk::console { } if {!$emit} { - puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1 + puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line, 1G cursor at col1 } set response "" if {[catch { @@ -1429,12 +1429,12 @@ namespace eval punk::console { proc cursor_save {} { #*** !doctools #[call [fun cursor_save]] - puts -nonewline \x1b\[s + puts -nonewline stdout \x1b\[s } proc cursor_restore {} { #*** !doctools #[call [fun cursor_restore]] - puts -nonewline \x1b\[u + puts -nonewline stdout \x1b\[u } #DEC equivalents of cursor_save/cursor_restore - perhaps more widely supported? proc cursor_save_dec {} { diff --git a/src/bootsupport/modules/punk/zip-0.1.0.tm b/src/bootsupport/modules/punk/zip-0.1.0.tm new file mode 100644 index 0000000..628419f --- /dev/null +++ b/src/bootsupport/modules/punk/zip-0.1.0.tm @@ -0,0 +1,632 @@ +# -*- 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.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::zip 0 0.1.0] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require 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 [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] + if {[llength $subdir]>0} { + set result [concat $result $dir $subdir] + } + } + return $result + } + + # Mkzipfile -- + # + # FIX ME: should handle the current offset for non-seekable channels + # + proc Mkzipfile {zipchan base path {comment ""}} { + #*** !doctools + #[call [fun Mkzipfile] [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 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 offset [tell $zipchan] + 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 $offset + 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 $offset] + append hdr $utfpath $extra $utfcomment + return $hdr + } + # zip::mkzip -- + # + # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt + # + proc mkzip {args} { + #*** !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 + -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 "" + -runtime -default "" -help "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + " + -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" + -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + *values -min 1 -max -1 + filename -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 -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 ""} { + set rt [open $opts(-runtime) rb] + fcopy $rt $zf + close $rt + } elseif {$opts(-zipkit)} { + 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 + } + set count 0 + set cd "" + + set members [list] + foreach path $paths { + #puts $path + lappend members $path + append cd [Mkzipfile $zf $base $path] ;#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.0 +}] +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 5d127a3..88fdc3f 100644 --- a/src/bootsupport/modules/textblock-0.1.1.tm +++ b/src/bootsupport/modules/textblock-0.1.1.tm @@ -1933,13 +1933,6 @@ tcl::namespace::eval textblock { set hval $ansibase_header$header ;#no reset set rowh [my header_height $hrow] - #set h_lines [lrepeat $rowh $hcell_line_blank] - #set hcell_blank [join $h_lines \n] - #set hval_lines [split $hval \n] - #set hval_lines [lrange $hval_lines 0 $rowh-1] - #set hval_block [join $hval_lines \n] - #set headercell [overtype::left -experimental test_mode $ansibase_header$hcell_blank$RST $hval_block] - if {$hrow == 0} { set hlims $header_boxlimits_toprow set rowpos "top" @@ -2146,7 +2139,7 @@ tcl::namespace::eval textblock { #puts $hblock #puts "==>hval:'$hval'[a]" #puts "==>hval:'[ansistring VIEW $hval]'" - #set spanned_frame [overtype::renderspace -experimental test_mode -transparent 1 $spanned_frame $hblock] + #set spanned_frame [overtype::renderspace -transparent 1 $spanned_frame $hblock] #spanned values default left - todo make configurable @@ -3504,11 +3497,11 @@ tcl::namespace::eval textblock { 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 -overflow 1 -experimental test_mode -transparent $TSUB $table[unset table] $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 -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol] + #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] } incr padwidth $bodywidth incr colposn @@ -3609,14 +3602,7 @@ tcl::namespace::eval textblock { 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}] -overflow 1 -experimental test_mode -transparent $TSUB $table $nextcol] - - #set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] - #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent $TSUB $table[unset table] $nextcol] - #JMN - - #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] - #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol] + set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] } incr padwidth $bodywidth incr colposn @@ -3726,7 +3712,7 @@ tcl::namespace::eval textblock { lappend body_blocks $nextcol_body } else { if {$headerheight > 0} { - set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -overflow 1 -experimental test_mode -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] + 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] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config index 490025b..75a091d 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config @@ -57,6 +57,7 @@ set bootsupport_modules [list\ modules punk::path\ modules punk::repo\ modules punk::tdl\ + modules punk::zip\ modules punk::winpath\ modules textblock\ modules oolib\ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/logger-0.9.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/logger-0.9.5.tm new file mode 100644 index 0000000..739e1c9 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/logger-0.9.5.tm @@ -0,0 +1,1297 @@ +# logger.tcl -- +# +# Tcl implementation of a general logging facility. +# +# Copyright (c) 2003 by David N. Welton +# Copyright (c) 2004-2011 by Michael Schlenker +# Copyright (c) 2006,2015 by Andreas Kupries +# +# See the file license.terms. + +# The logger package provides an 'object oriented' log facility that +# lets you have trees of services, that inherit from one another. +# This is accomplished through the use of Tcl namespaces. + + +package require Tcl 8.5 9 +package provide logger 0.9.5 + +namespace eval ::logger { + namespace eval tree {} + namespace export init enable disable services servicecmd import + + # The active services. + variable services {} + + # The log 'levels'. + variable levels [list debug info notice warn error critical alert emergency] + + # The default global log level used for new logging services + variable enabled "debug" + + # Tcl return codes (in numeric order) + variable RETURN_CODES [list "ok" "error" "return" "break" "continue"] +} + +# Try to load msgcat and fall back to format if it fails +if {[catch {package require msgcat}]} { + interp alias {} ::logger::mc {} ::format +} else { + namespace eval ::logger { + namespace import ::msgcat::mc + } +} + +# ::logger::_nsExists -- +# +# Workaround for missing namespace exists in Tcl 8.2 and 8.3. +# + +if {[package vcompare [package provide Tcl] 8.4] < 0} { + proc ::logger::_nsExists {ns} { + expr {![catch {namespace parent $ns}]} + } +} else { + proc ::logger::_nsExists {ns} { + namespace exists $ns + } +} + +# ::logger::_cmdPrefixExists -- +# +# Utility function to check if a given callback prefix exists, +# this should catch all oddities in prefix names, including spaces, +# glob patterns, non normalized namespaces etc. +# +# Arguments: +# prefix - The command prefix to check +# +# Results: +# 1 or 0 for yes or no +# +proc ::logger::_cmdPrefixExists {prefix} { + set cmd [lindex $prefix 0] + set full [namespace eval :: namespace which [list $cmd]] + if {[string equal $full ""]} {return 0} else {return 1} + # normalize namespaces + set ns [namespace qualifiers $cmd] + set cmd ${ns}::[namespace tail $cmd] + set matches [::info commands ${ns}::*] + if {[lsearch -exact $matches $cmd] != -1} {return 1} + return 0 +} + +# ::logger::walk -- +# +# Walk namespaces, starting in 'start', and evaluate 'code' in +# them. +# +# Arguments: +# start - namespace to start in. +# code - code to execute in namespaces walked. +# +# Side Effects: +# Side effects of code executed. +# +# Results: +# None. + +proc ::logger::walk { start code } { + set children [namespace children $start] + foreach c $children { + logger::walk $c $code + namespace eval $c $code + } +} + +proc ::logger::init {service} { + variable levels + variable services + variable enabled + + if {[string length [string trim $service {:}]] == 0} { + return -code error \ + -errorcode [list LOGGER EMPTY_SERVICENAME] \ + [::logger::mc "Service name invalid. May not consist only of : or be empty"] + } + # We create a 'tree' namespace to house all the services, so + # they are in a 'safe' namespace sandbox, and won't overwrite + # any commands. + namespace eval tree::${service} { + variable service + variable levels + variable oldname + variable enabled + } + + lappend services $service + + set [namespace current]::tree::${service}::service $service + set [namespace current]::tree::${service}::levels $levels + set [namespace current]::tree::${service}::oldname $service + set [namespace current]::tree::${service}::enabled $enabled + + namespace eval tree::${service} { + # Callback to use when the service in question is shut down. + variable delcallback [namespace current]::no-op + + # Callback when the loglevel is changed + variable levelchangecallback [namespace current]::no-op + + # State variable to decide when to call levelcallback + variable inSetLevel 0 + + # The currently configured levelcommands + variable lvlcmds + array set lvlcmds {} + + # List of procedures registered via the trace command + variable traceList "" + + # Flag indicating whether or not tracing is currently enabled + variable tracingEnabled 0 + + # We use this to disable a service completely. In Tcl 8.4 + # or greater, by using this, disabled log calls are a + # no-op! + + proc no-op args {} + + proc stdoutcmd {level text} { + variable service + puts "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'" + } + + proc stderrcmd {level text} { + variable service + puts stderr "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'" + } + + + # setlevel -- + # + # This command differs from enable and disable in that + # it disables all the levels below that selected, and + # then enables all levels above it, which enable/disable + # do not do. + # + # Arguments: + # lv - the level, as defined in $levels. + # + # Side Effects: + # Runs disable for the level, and then enable, in order + # to ensure that all levels are set correctly. + # + # Results: + # None. + + + proc setlevel {lv} { + variable inSetLevel 1 + set oldlvl [currentloglevel] + + # do not allow enable and disable to do recursion + if {[catch { + disable $lv 0 + set newlvl [enable $lv 0] + } msg] == 1} { + return -code error -errorcode $::errorCode $msg + } + # do the recursion here + logger::walk [namespace current] [list setlevel $lv] + + set inSetLevel 0 + lvlchangewrapper $oldlvl $newlvl + return + } + + # enable -- + # + # Enable a particular 'level', and above, for the + # service, and its 'children'. + # + # Arguments: + # lv - the level, as defined in $levels. + # + # Side Effects: + # Enables logging for the particular level, and all + # above it (those more important). It also walks + # through all services that are 'children' and enables + # them at the same level or above. + # + # Results: + # None. + + proc enable {lv {recursion 1}} { + variable levels + set lvnum [lsearch -exact $levels $lv] + if { $lvnum == -1 } { + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] + } + + variable enabled + set newlevel $enabled + set elnum [lsearch -exact $levels $enabled] + if {($elnum == -1) || ($elnum > $lvnum)} { + set newlevel $lv + } + + variable service + while { $lvnum < [llength $levels] } { + interp alias {} [namespace current]::[lindex $levels $lvnum] \ + {} [namespace current]::[lindex $levels $lvnum]cmd + incr lvnum + } + + if {$recursion} { + logger::walk [namespace current] [list enable $lv] + } + lvlchangewrapper $enabled $newlevel + set enabled $newlevel + } + + # disable -- + # + # Disable a particular 'level', and below, for the + # service, and its 'children'. + # + # Arguments: + # lv - the level, as defined in $levels. + # + # Side Effects: + # Disables logging for the particular level, and all + # below it (those less important). It also walks + # through all services that are 'children' and disables + # them at the same level or below. + # + # Results: + # None. + + proc disable {lv {recursion 1}} { + variable levels + set lvnum [lsearch -exact $levels $lv] + if { $lvnum == -1 } { + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] + } + + variable enabled + set newlevel $enabled + set elnum [lsearch -exact $levels $enabled] + if {($elnum > -1) && ($elnum <= $lvnum)} { + if {$lvnum+1 >= [llength $levels]} { + set newlevel "none" + } else { + set newlevel [lindex $levels [expr {$lvnum+1}]] + } + } + + while { $lvnum >= 0 } { + + interp alias {} [namespace current]::[lindex $levels $lvnum] {} \ + [namespace current]::no-op + incr lvnum -1 + } + if {$recursion} { + logger::walk [namespace current] [list disable $lv] + } + lvlchangewrapper $enabled $newlevel + set enabled $newlevel + } + + # currentloglevel -- + # + # Get the currently enabled log level for this service. + # + # Arguments: + # none + # + # Side Effects: + # none + # + # Results: + # current log level + # + + proc currentloglevel {} { + variable enabled + return $enabled + } + + # lvlchangeproc -- + # + # Set or introspect a callback for when the logger instance + # changes its loglevel. + # + # Arguments: + # cmd - the Tcl command to call, it is called with two parameters, old and new log level. + # or none for introspection + # + # Side Effects: + # None. + # + # Results: + # If no arguments are given return the current callback cmd. + + proc lvlchangeproc {args} { + variable levelchangecallback + + switch -exact -- [llength [::info level 0]] { + 1 {return $levelchangecallback} + 2 { + if {[::logger::_cmdPrefixExists [lindex $args 0]]} { + set levelchangecallback [lindex $args 0] + } else { + return -code error \ + -errorcode [list LOGGER INVALID_CMD] \ + [::logger::mc "Invalid cmd '%s' - does not exist" [lindex $args 0]] + } + } + default { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "Wrong # of arguments. Usage: \${log}::lvlchangeproc ?cmd?"] + } + } + } + + proc lvlchangewrapper {old new} { + variable inSetLevel + + # we are called after disable and enable are finished + if {$inSetLevel} {return} + + # no action if level does not change + if {[string equal $old $new]} {return} + + variable levelchangecallback + # no action if levelchangecallback isn't a valid command + if {[::logger::_cmdPrefixExists $levelchangecallback]} { + catch { + uplevel \#0 [linsert $levelchangecallback end $old $new] + } + } + } + + # logproc -- + # + # Command used to create a procedure that is executed to + # perform the logging. This could write to disk, out to + # the network, or something else. + # If two arguments are given, use an existing command. + # If three arguments are given, create a proc. + # + # Arguments: + # lv - the level to log, which must be one of $levels. + # args - either zero, one or two arguments. + # if zero this returns the current command registered + # if one, this is a cmd name that is called for this level + # if two, these are an argument and proc body + # + # Side Effects: + # Creates a logging command to take care of the details + # of logging an event. + # + # Results: + # If called with zero length args, returns the name of the currently + # configured logging procedure. + # + # + + proc logproc {lv args} { + variable levels + variable lvlcmds + + set lvnum [lsearch -exact $levels $lv] + if { ($lvnum == -1) && ($lv != "trace") } { + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] + } + switch -exact -- [llength $args] { + 0 { + return $lvlcmds($lv) + } + 1 { + set cmd [lindex $args 0] + if {[string equal "[namespace current]::${lv}cmd" $cmd]} {return} + if {[llength [::info commands $cmd]]} { + proc ${lv}cmd args [format { + uplevel 1 [list %s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] + } $cmd] + } else { + return -code error \ + -errorcode [list LOGGER INVALID_CMD] \ + [::logger::mc "Invalid cmd '%s' - does not exist" $cmd] + } + set lvlcmds($lv) $cmd + } + 2 { + foreach {arg body} $args {break} + proc ${lv}cmd args [format {\ + _setservicename args + set val [%s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] + _restoreservice + set val} ${lv}customcmd] + proc ${lv}customcmd $arg $body + set lvlcmds($lv) [namespace current]::${lv}customcmd + } + default { + return -code error \ + -errorcode [list LOGGER WRONG_USAGE] \ + [::logger::mc \ + "Usage: \${log}::logproc level ?cmd?\nor \${log}::logproc level argname body" ] + } + } + } + + + # delproc -- + # + # Set or introspect a callback for when the logger instance + # is deleted. + # + # Arguments: + # cmd - the Tcl command to call. + # or none for introspection + # + # Side Effects: + # None. + # + # Results: + # If no arguments are given return the current callback cmd. + + proc delproc {args} { + variable delcallback + + switch -exact -- [llength [::info level 0]] { + 1 {return $delcallback} + 2 { if {[::logger::_cmdPrefixExists [lindex $args 0]]} { + set delcallback [lindex $args 0] + } else { + return -code error \ + -errorcode [list LOGGER INVALID_CMD] \ + [::logger::mc "Invalid cmd '%s' - does not exist" [lindex $args 0]] + } + } + default { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "Wrong # of arguments. Usage: \${log}::delproc ?cmd?"] + } + } + } + + + # delete -- + # + # Delete the namespace and its children. + + proc delete {} { + variable delcallback + variable service + + logger::walk [namespace current] delete + if {[::logger::_cmdPrefixExists $delcallback]} { + uplevel \#0 [lrange $delcallback 0 end] + } + # clean up the global services list + set idx [lsearch -exact [logger::services] $service] + if {$idx !=-1} { + set ::logger::services [lreplace [logger::services] $idx $idx] + } + + namespace delete [namespace current] + + } + + # services -- + # + # Return all child services + + proc services {} { + variable service + + set children [list] + foreach srv [logger::services] { + if {[string match "${service}::*" $srv]} { + lappend children $srv + } + } + return $children + } + + # servicename -- + # + # Return the name of the service + + proc servicename {} { + variable service + return $service + } + + proc _setservicename {argname} { + variable service + variable oldname + upvar 1 $argname arg + if {[llength $arg] <= 1} { + return + } + + set count -1 + set newname "" + while {[string equal [lindex $arg [expr {$count+1}]] "-_logger::service"]} { + incr count 2 + set newname [lindex $arg $count] + } + if {[string equal $newname ""]} { + return + } + set oldname $service + set service $newname + # Pop off "-_logger::service " from argument list + set arg [lreplace $arg 0 $count] + } + + proc _restoreservice {} { + variable service + variable oldname + set service $oldname + return + } + + proc trace { action args } { + variable service + + # Allow other boolean values (true, false, yes, no, 0, 1) to be used + # as synonymns for "on" and "off". + + if {[string is boolean $action]} { + set xaction [expr {($action && 1) ? "on" : "off"}] + } else { + set xaction $action + } + + # Check for required arguments for actions/subcommands and dispatch + # to the appropriate procedure. + + switch -- $xaction { + "status" { + return [uplevel 1 [list logger::_trace_status $service $args]] + } + "on" { + if {[llength $args]} { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace on\""] + } + return [logger::_trace_on $service] + } + "off" { + if {[llength $args]} { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace off\""] + } + return [logger::_trace_off $service] + } + "add" { + if {![llength $args]} { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace add ?-ns? ...\""] + } + return [uplevel 1 [list ::logger::_trace_add $service $args]] + } + "remove" { + if {![llength $args]} { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace remove ?-ns? ...\""] + } + return [uplevel 1 [list ::logger::_trace_remove $service $args]] + } + + default { + return -code error \ + -errorcode [list LOGGER INVALID_ARG] \ + [::logger::mc "Invalid action \"%s\": must be status, add, remove,\ + on, or off" $action] + } + } + } + + # Walk the parent service namespaces to see first, if they + # exist, and if any are enabled, and then, as a + # consequence, enable this one + # too. + + enable $enabled + variable parent [namespace parent] + while {[string compare $parent "::logger::tree"]} { + # If the 'enabled' variable doesn't exist, create the + # whole thing. + if { ! [::info exists ${parent}::enabled] } { + logger::init [string range $parent 16 end] + } + set enabled [set ${parent}::enabled] + enable $enabled + set parent [namespace parent $parent] + } + } + + # Now create the commands for different levels. + + namespace eval tree::${service} { + set parent [namespace parent] + + # We 'inherit' the commands from the parents. This + # means that, if you want to share the same methods with + # children, they should be instantiated after the parent's + # methods have been defined. + + variable lvl ; # prevent creative writing to the global scope + if {[string compare $parent "::logger::tree"]} { + foreach lvl [::logger::levels] { + # OPTIMIZE: do not allow multiple aliases in the hierarchy + # they can always be replaced by more efficient + # direct aliases to the target procs. + interp alias {} [namespace current]::${lvl}cmd \ + {} ${parent}::${lvl}cmd -_logger::service $service + } + # inherit the starting loglevel of the parent service + setlevel [${parent}::currentloglevel] + } else { + foreach lvl [concat [::logger::levels] "trace"] { + proc ${lvl}cmd args [format {\ + _setservicename args + set val [stdoutcmd %s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] + _restoreservice + set val } $lvl] + + set lvlcmds($lvl) [namespace current]::${lvl}cmd + } + setlevel $::logger::enabled + } + unset lvl ; # drop the temp iteration variable + } + + return ::logger::tree::${service} +} + +# ::logger::services -- +# +# Returns a list of all active services. +# +# Arguments: +# None. +# +# Side Effects: +# None. +# +# Results: +# List of active services. + +proc ::logger::services {} { + variable services + return $services +} + +# ::logger::enable -- +# +# Global enable for a certain level. NOTE - this implementation +# isn't terribly effective at the moment, because it might hit +# children before their parents, who will then walk down the +# tree attempting to disable the children again. +# +# Arguments: +# lv - level above which to enable logging. +# +# Side Effects: +# Enables logging in a given level, and all higher levels. +# +# Results: +# None. + +proc ::logger::enable {lv} { + variable services + if {[catch { + foreach sv $services { + ::logger::tree::${sv}::enable $lv + } + } msg] == 1} { + return -code error -errorcode $::errorCode $msg + } +} + +proc ::logger::disable {lv} { + variable services + if {[catch { + foreach sv $services { + ::logger::tree::${sv}::disable $lv + } + } msg] == 1} { + return -code error -errorcode $::errorCode $msg + } +} + +proc ::logger::setlevel {lv} { + variable services + variable enabled + variable levels + if {[lsearch -exact $levels $lv] == -1} { + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] + } + set enabled $lv + if {[catch { + foreach sv $services { + ::logger::tree::${sv}::setlevel $lv + } + } msg] == 1} { + return -code error -errorcode $::errorCode $msg + } +} + +# ::logger::levels -- +# +# Introspect the available log levels. Provided so a caller does +# not need to know implementation details or code the list +# himself. +# +# Arguments: +# None. +# +# Side Effects: +# None. +# +# Results: +# levels - The list of valid log levels accepted by enable and disable + +proc ::logger::levels {} { + variable levels + return $levels +} + +# ::logger::servicecmd -- +# +# Get the command token for a given service name. +# +# Arguments: +# service - name of the service. +# +# Side Effects: +# none +# +# Results: +# log - namespace token for this service + +proc ::logger::servicecmd {service} { + variable services + if {[lsearch -exact $services $service] == -1} { + return -code error \ + -errorcode [list LOGGER NO_SUCH_SERVICE] \ + [::logger::mc "Service \"%s\" does not exist." $service] + } + return "::logger::tree::${service}" +} + +# ::logger::import -- +# +# Import the logging commands. +# +# Arguments: +# service - name of the service. +# +# Side Effects: +# creates aliases in the target namespace +# +# Results: +# none + +proc ::logger::import {args} { + variable services + + if {[llength $args] == 0 || [llength $args] > 7} { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc \ + "Wrong # of arguments: \"logger::import ?-all?\ + ?-force?\ + ?-prefix prefix? ?-namespace namespace? service\""] + } + + # process options + # + set import_all 0 + set force 0 + set prefix "" + set ns [uplevel 1 namespace current] + while {[llength $args] > 1} { + set opt [lindex $args 0] + set args [lrange $args 1 end] + switch -exact -- $opt { + -all { set import_all 1} + -prefix { set prefix [lindex $args 0] + set args [lrange $args 1 end] + } + -namespace { + set ns [lindex $args 0] + set args [lrange $args 1 end] + } + -force { + set force 1 + } + default { + return -code error \ + -errorcode [list LOGGER UNKNOWN_ARG] \ + [::logger::mc \ + "Unknown argument: \"%s\" :\nUsage:\ + \"logger::import ?-all? ?-force?\ + ?-prefix prefix? ?-namespace namespace? service\"" $opt] + } + } + } + + # + # build the list of commands to import + # + + set cmds [logger::levels] + lappend cmds "trace" + if {$import_all} { + lappend cmds setlevel enable disable logproc delproc services + lappend cmds servicename currentloglevel delete + } + + # + # check the service argument + # + + set service [lindex $args 0] + if {[lsearch -exact $services $service] == -1} { + return -code error \ + -errorcode [list LOGGER NO_SUCH_SERVICE] \ + [::logger::mc "Service \"%s\" does not exist." $service] + } + + # + # setup the namespace for the import + # + + set sourcens [logger::servicecmd $service] + set localns [uplevel 1 namespace current] + + if {[string match ::* $ns]} { + set importns $ns + } else { + set importns ${localns}::$ns + } + + # fake namespace exists for Tcl 8.2 - 8.3 + if {![_nsExists $importns]} { + namespace eval $importns {} + } + + + # + # prepare the import + # + + set imports "" + foreach cmd $cmds { + set cmdname ${importns}::${prefix}$cmd + set collision [llength [info commands $cmdname]] + if {$collision && !$force} { + return -code error \ + -errorcode [list LOGGER IMPORT_NAME_EXISTS] \ + [::logger::mc "can't import command \"%s\": already exists" $cmdname] + } + lappend imports ${importns}::${prefix}$cmd ${sourcens}::${cmd} + } + + # + # and execute the aliasing after checking all is well + # + + foreach {target source} $imports { + proc $target {args} "uplevel 1 \[linsert \$args 0 $source \]" + } +} + +# ::logger::initNamespace -- +# +# Creates a logger for the specified namespace and makes the log +# commands available to said namespace as well. Allows the initial +# setting of a default log level. +# +# Arguments: +# ns - Namespace to initialize, is also the service name, modulo a ::-prefix +# level - Initial log level, optional, defaults to 'warn'. +# +# Side Effects: +# creates aliases in the target namespace +# +# Results: +# none + +proc ::logger::initNamespace {ns {level {}}} { + set service [string trimleft $ns :] + if {$level == ""} { + # No user-specified level. Figure something out. + # - If the parent service exists then the 'logger::init' + # below will automatically inherit its level. Good enough. + # - Without a parent service go and use a default level of 'warn'. + set parent [string trimleft [namespace qualifiers $service] :] + set hasparent [expr {($parent != {}) && [_nsExists ::logger::tree::${parent}]}] + if {!$hasparent} { + set level warn + } + } + + namespace eval $ns [list ::logger::init $service] + namespace eval $ns [list ::logger::import -force -all -namespace log $service] + if {$level != ""} { + namespace eval $ns [list log::setlevel $level] + } + return +} + +# This procedure handles the "logger::trace status" command. Given no +# arguments, returns a list of all procedures that have been registered +# via "logger::trace add". Given one or more procedure names, it will +# return 1 if all were registered, or 0 if any were not. + +proc ::logger::_trace_status { service procList } { + upvar #0 ::logger::tree::${service}::traceList traceList + + # If no procedure names were given, just return the registered list + + if {![llength $procList]} { + return $traceList + } + + # Get caller's namespace for qualifying unqualified procedure names + + set caller_ns [uplevel 1 namespace current] + set caller_ns [string trimright $caller_ns ":"] + + # Search for any specified proc names that are *not* registered + + foreach procName $procList { + # Make sure the procedure namespace is qualified + + if {![string match "::*" $procName]} { + set procName ${caller_ns}::$procName + } + + # Check if the procedure has been registered for tracing + + if {[lsearch -exact $traceList $procName] == -1} { + return 0 + } + } + + return 1 +} + +# This procedure handles the "logger::trace on" command. If tracing +# is turned off, it will enable Tcl trace handlers for all of the procedures +# registered via "logger::trace add". Does nothing if tracing is already +# turned on. + +proc ::logger::_trace_on { service } { + set tcl_version [package provide Tcl] + + if {[package vcompare $tcl_version "8.4"] < 0} { + return -code error \ + -errorcode [list LOGGER TRACE_NOT_AVAILABLE] \ + [::logger::mc "execution tracing is not available in Tcl %s" $tcl_version] + } + + namespace eval ::logger::tree::${service} { + if {!$tracingEnabled} { + set tracingEnabled 1 + ::logger::_enable_traces $service $traceList + } + } + + return 1 +} + +# This procedure handles the "logger::trace off" command. If tracing +# is turned on, it will disable Tcl trace handlers for all of the procedures +# registered via "logger::trace add", leaving them in the list so they +# tracing on all of them can be enabled again with "logger::trace on". +# Does nothing if tracing is already turned off. + +proc ::logger::_trace_off { service } { + namespace eval ::logger::tree::${service} { + if {$tracingEnabled} { + ::logger::_disable_traces $service $traceList + set tracingEnabled 0 + } + } + + return 1 +} + +# This procedure is used by the logger::trace add and remove commands to +# process the arguments in a common fashion. If the -ns switch is given +# first, this procedure will return a list of all existing procedures in +# all of the namespaces given in remaining arguments. Otherwise, each +# argument is taken to be either a pattern for a glob-style search of +# procedure names or, failing that, a namespace, in which case this +# procedure returns a list of all the procedures matching the given +# pattern (or all in the named namespace, if no procedures match). + +proc ::logger::_trace_get_proclist { inputList } { + set procList "" + + if {[string equal [lindex $inputList 0] "-ns"]} { + # Verify that at least one target namespace was supplied + + set inputList [lrange $inputList 1 end] + if {![llength $inputList]} { + return -code error \ + -errorcode [list LOGGER TARGET_MISSING] \ + [::logger::mc "Must specify at least one namespace target"] + } + + # Rebuild the argument list to contain namespace procedures + + foreach namespace $inputList { + # Don't allow tracing of the logger (or child) namespaces + + if {![string match "::logger::*" $namespace]} { + set nsProcList [::info procs ${namespace}::*] + set procList [concat $procList $nsProcList] + } + } + } else { + # Search for procs or namespaces matching each of the specified + # patterns. + + foreach pattern $inputList { + set matches [uplevel 1 ::info proc $pattern] + + if {![llength $matches]} { + if {[uplevel 1 namespace exists $pattern]} { + set matches [::info procs ${pattern}::*] + } + + # Matched procs will be qualified due to above pattern + + set procList [concat $procList $matches] + } elseif {[string match "::*" $pattern]} { + # Patterns were pre-qualified - add them directly + + set procList [concat $procList $matches] + } else { + # Qualify each proc with the namespace it was in + + set ns [uplevel 1 namespace current] + if {$ns == "::"} { + set ns "" + } + foreach proc $matches { + lappend procList ${ns}::$proc + } + } + } + } + + return $procList +} + +# This procedure handles the "logger::trace add" command. If the tracing +# feature is enabled, it will enable the Tcl entry and leave trace handlers +# for each procedure specified that isn't already being traced. Each +# procedure is added to the list of procedures that the logger trace feature +# should log when tracing is enabled. + +proc ::logger::_trace_add { service procList } { + upvar #0 ::logger::tree::${service}::traceList traceList + + # Handle -ns switch and glob search patterns for procedure names + + set procList [uplevel 1 [list logger::_trace_get_proclist $procList]] + + # Enable tracing for each procedure that has not previously been + # specified via logger::trace add. If tracing is off, this will just + # store the name of the procedure for later when tracing is turned on. + + foreach procName $procList { + if {[lsearch -exact $traceList $procName] == -1} { + lappend traceList $procName + ::logger::_enable_traces $service [list $procName] + } + } +} + +# This procedure handles the "logger::trace remove" command. If the tracing +# feature is enabled, it will remove the Tcl entry and leave trace handlers +# for each procedure specified. Each procedure is removed from the list +# of procedures that the logger trace feature should log when tracing is +# enabled. + +proc ::logger::_trace_remove { service procList } { + upvar #0 ::logger::tree::${service}::traceList traceList + + # Handle -ns switch and glob search patterns for procedure names + + set procList [uplevel 1 [list logger::_trace_get_proclist $procList]] + + # Disable tracing for each proc that previously had been specified + # via logger::trace add. If tracing is off, this will just + # remove the name of the procedure from the trace list so that it + # will be excluded when tracing is turned on. + + foreach procName $procList { + set index [lsearch -exact $traceList $procName] + if {$index != -1} { + set traceList [lreplace $traceList $index $index] + ::logger::_disable_traces $service [list $procName] + } + } +} + +# This procedure enables Tcl trace handlers for all procedures specified. +# It is used both to enable Tcl's tracing for a single procedure when +# removed via "logger::trace add", as well as to enable all traces +# via "logger::trace on". + +proc ::logger::_enable_traces { service procList } { + upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled + + if {$tracingEnabled} { + foreach procName $procList { + ::trace add execution $procName enter \ + [list ::logger::_trace_enter $service] + ::trace add execution $procName leave \ + [list ::logger::_trace_leave $service] + } + } +} + +# This procedure disables Tcl trace handlers for all procedures specified. +# It is used both to disable Tcl's tracing for a single procedure when +# removed via "logger::trace remove", as well as to disable all traces +# via "logger::trace off". + +proc ::logger::_disable_traces { service procList } { + upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled + + if {$tracingEnabled} { + foreach procName $procList { + ::trace remove execution $procName enter \ + [list ::logger::_trace_enter $service] + ::trace remove execution $procName leave \ + [list ::logger::_trace_leave $service] + } + } +} + +######################################################################## +# Trace Handlers +######################################################################## + +# This procedure is invoked upon entry into a procedure being traced +# via "logger::trace add" when tracing is enabled via "logger::trace on" +# to log information about how the procedure was called. + +proc ::logger::_trace_enter { service cmd op } { + # Parse the command + set procName [uplevel 1 namespace origin [lindex $cmd 0]] + set args [lrange $cmd 1 end] + + # Display the message prefix + set callerLvl [expr {[::info level] - 1}] + set calledLvl [::info level] + + lappend message "proc" $procName + lappend message "level" $calledLvl + lappend message "script" [uplevel ::info script] + + # Display the caller information + set caller "" + if {$callerLvl >= 1} { + # Display the name of the caller proc w/prepended namespace + catch { + set callerProcName [lindex [::info level $callerLvl] 0] + set caller [uplevel 2 namespace origin $callerProcName] + } + } + + lappend message "caller" $caller + + # Display the argument names and values + set argSpec [uplevel 1 ::info args $procName] + set argList "" + if {[llength $argSpec]} { + foreach argName $argSpec { + lappend argList $argName + + if {$argName == "args"} { + lappend argList $args + break + } else { + lappend argList [lindex $args 0] + set args [lrange $args 1 end] + } + } + } + + lappend message "procargs" $argList + set message [list $op $message] + + ::logger::tree::${service}::tracecmd $message +} + +# This procedure is invoked upon leaving into a procedure being traced +# via "logger::trace add" when tracing is enabled via "logger::trace on" +# to log information about the result of the procedure call. + +proc ::logger::_trace_leave { service cmd status rc op } { + variable RETURN_CODES + + # Parse the command + set procName [uplevel 1 namespace origin [lindex $cmd 0]] + + # Gather the caller information + set callerLvl [expr {[::info level] - 1}] + set calledLvl [::info level] + + lappend message "proc" $procName "level" $calledLvl + lappend message "script" [uplevel ::info script] + + # Get the name of the proc being returned to w/prepended namespace + set caller "" + catch { + set callerProcName [lindex [::info level $callerLvl] 0] + set caller [uplevel 2 namespace origin $callerProcName] + } + + lappend message "caller" $caller + + # Convert the return code from numeric to verbal + + if {$status < [llength $RETURN_CODES]} { + set status [lindex $RETURN_CODES $status] + } + + lappend message "status" $status + lappend message "result" $rc + + # Display the leave message + + set message [list $op $message] + ::logger::tree::${service}::tracecmd $message + + return 1 +} + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm index f7e4c1a..38ce71c 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm @@ -165,16 +165,17 @@ tcl::namespace::eval overtype::priv { #could return larger than renderwidth proc _get_row_append_column {row} { + #obsolete? upvar outputlines outputlines set idx [expr {$row -1}] if {$row <= 1 || $row > [llength $outputlines]} { return 1 } else { - upvar opt_overflow opt_overflow + upvar opt_expand_right expand_right upvar renderwidth renderwidth set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] set endpos [expr {$existinglen +1}] - if {$opt_overflow} { + if {$expand_right} { return $endpos } else { if {$endpos > $renderwidth} { @@ -204,14 +205,14 @@ tcl::namespace::eval overtype { 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 + #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [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: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} } set optargs [lrange $args 0 end-2] if {[llength $optargs] % 2 == 0} { @@ -228,30 +229,46 @@ tcl::namespace::eval overtype { } } set opts [tcl::dict::create\ - -bias ignored\ - -width \uFFEF\ - -height \uFFEF\ + -bias ignored\ + -width \uFFEF\ + -height \uFFEF\ -startcolumn 1\ - -wrap 0\ - -ellipsis 0\ + -wrap 0\ + -ellipsis 0\ -ellipsistext $default_ellipsis_horizontal\ -ellipsiswhitespace 0\ - -overflow 0\ - -appendlines 1\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -experimental 0\ - -looplimit \uFFEF\ - -crm_mode 0\ - -reverse_mode 0\ + -expand_right 0\ + -appendlines 1\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -experimental 0\ + -cp437 1\ + -looplimit \uFFEF\ + -crm_mode 0\ + -reverse_mode 0\ + -insert_mode 0\ + -console {stdin stdout stderr}\ ] + #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. + # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) + # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. + # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. + # - further implication is that if expand_right grows the virtual renderspace terminal width - + # then some sort of reflow/rerender needs to be done for preceeding lines? + # possibly not - as expand_right is distinct from a normal terminal-width change event, + # expand_right being primarily to support other operations such as textblock::table + + #todo - viewport width/height as separate concept to terminal width/height? #-ellipsis args not used if -wrap is true foreach {k v} $argsflags { switch -- $k { - -looplimit - -width - -height - -startcolumn - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -appendlines + -looplimit - -width - -height - -startcolumn - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -transparent - -exposed1 - -exposed2 - -experimental - - -reverse_mode - -crm_mode { + - -expand_right - -appendlines + - -reverse_mode - -crm_mode - -insert_mode + - -cp437 + - -console { tcl::dict::set opts $k $v } default { @@ -261,7 +278,8 @@ tcl::namespace::eval overtype { } #set opts [tcl::dict::merge $defaults $argsflags] # -- --- --- --- --- --- - set opt_overflow [tcl::dict::get $opts -overflow] + #review - expand_left for RTL text? + set opt_expand_right [tcl::dict::get $opts -expand_right] ##### # 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) @@ -279,23 +297,31 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- set opt_crm_mode [tcl::dict::get $opts -crm_mode] set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] + set opt_insert_mode [tcl::dict::get $opts -insert_mode] + # -- --- --- --- --- --- + set opt_cp437 [tcl::dict::get $opts -cp437] + + + #initial state for renderspace 'terminal' reset + set initial_state [dict create\ + -width $opt_width\ + -height $opt_height\ + -crm_mode $opt_crm_mode\ + -reverse_mode $opt_reverse_mode\ + -insert_mode $opt_insert_mode\ + -cp437 $opt_cp437\ + ] # ---------------------------- # -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 { @@ -309,11 +335,10 @@ tcl::namespace::eval overtype { } } } - 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 insert_mode $opt_insert_mode ;#can be toggled by insert key or ansi IRM sequence ESC [ 4 h|l set autowrap_mode $opt_wrap set reverse_mode $opt_reverse_mode set crm_mode $opt_crm_mode @@ -377,49 +402,45 @@ tcl::namespace::eval overtype { 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] + 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 } - 1 { - set inputchunks [punk::ansi::ta::split_codes $overblock] + } + 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 } - 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 - } + if {[llength $lflines]} { + lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] } - 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] + set inputchunks $lflines[unset lflines] - } } } @@ -441,11 +462,11 @@ tcl::namespace::eval overtype { #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 { + #if {$data_mode} { + # set col [_get_row_append_column $row] + #} else { set col $opt_startcolumn - } + #} set instruction_stats [tcl::dict::create] @@ -473,33 +494,27 @@ tcl::namespace::eval overtype { } #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\ - -crm_mode $crm_mode\ - -autowrap_mode $autowrap_mode\ - -reverse_mode $reverse_mode\ - -transparent $opt_transparent\ - -width $renderwidth\ - -exposed1 $opt_exposed1\ - -exposed2 $opt_exposed2\ - -overflow $opt_overflow -cursor_column $col -cursor_row $row $undertext $overtext] - set rinfo [renderline -experimental $opt_experimental\ + set renderargs [list -experimental $opt_experimental\ + -cp437 $opt_cp437\ -info 1\ -crm_mode $crm_mode\ -insert_mode $insert_mode\ -autowrap_mode $autowrap_mode\ - -reverse_mode $reverse_mode\ + -reverse_mode $reverse_mode\ -cursor_restore_attributes $cursor_saved_attributes\ -transparent $opt_transparent\ -width $renderwidth\ -exposed1 $opt_exposed1\ -exposed2 $opt_exposed2\ - -overflow $opt_overflow\ + -expand_right $opt_expand_right\ -cursor_column $col\ -cursor_row $row\ $undertext\ $overtext\ - ] + ] + set LASTCALL $renderargs + set rinfo [renderline {*}$renderargs] + 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] ;# @@ -523,6 +538,7 @@ tcl::namespace::eval overtype { #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] if {0 && $reverse_mode} { + #test branch - todo - prune puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" #review #JMN3 @@ -579,29 +595,17 @@ tcl::namespace::eval overtype { #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 > $renderwidth} { + reset { + #reset the 'renderspace terminal' (not underlying terminal) + set row 1 + set col 1 - } - } 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 - #} - } + } + {} { + #lf included in data + set row $post_render_row + set col $post_render_col } up { @@ -704,7 +708,14 @@ tcl::namespace::eval overtype { puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" - set sub_info [overtype::renderline -info 1 -width $renderwidth -insert_mode $insert_mode -autowrap_mode $autowrap_mode -overflow [tcl::dict::get $opts -overflow] "" $overflow_right] + set sub_info [overtype::renderline -info 1\ + -width $renderwidth\ + -insert_mode $insert_mode\ + -autowrap_mode $autowrap_mode\ + -expand_right [tcl::dict::get $opts -opt_expand_right]\ + ""\ + $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.. @@ -735,7 +746,7 @@ tcl::namespace::eval overtype { #overflow + unapplied? } lf_start { - #raw newlines - must be test_mode + #raw newlines # ---------------------- #test with fruit.ans #test - treating as newline below... @@ -751,48 +762,58 @@ tcl::namespace::eval overtype { } 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 edit_mode 0 + if {$edit_mode} { + set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] set overflow_right "" - - - set row $renderedrow - + set unapplied "" + set row $post_render_row + #set col $post_render_col 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 "" + if 1 { + if {$overflow_right ne ""} { + if {$opt_expand_right} { + append rendered $overflow_right + set overflow_right "" + } else { + set overflow_width [punk::ansi::printing_length $overflow_right] + if {$visualwidth + $overflow_width <= $renderwidth} { + append rendered $overflow_right + set overflow_right "" + } else { + if {$visualwidth < $renderwidth} { + set graphemes [punk::char::grapheme_split $overflow_width] + set add "" + set addlen $visualwidth + set remaining_overflow $graphemes + foreach g $graphemes { + set w [overtype::grapheme_width_cached] + if {$addlen + $w <= $renderwidth} { + append add $g + incr addlen $w + lpop remaining_overflow + } else { + break + } + } + append rendered $add + set overflow_right [join $remaining_overflow ""] + } + } + } + } set row $post_render_row - #set col $post_render_col set col $opt_startcolumn if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } } else { + #old version - known to work with various ansi graphics - e.g fruit.ans + # - but fails to limit lines to renderwidth when expand_right == 0 append rendered $overflow_right set overflow_right "" set row $post_render_row @@ -851,38 +872,28 @@ tcl::namespace::eval overtype { 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 + #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 @@ -974,7 +985,6 @@ tcl::namespace::eval overtype { 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] @@ -1052,7 +1062,7 @@ tcl::namespace::eval overtype { } - if {!$opt_overflow && !$autowrap_mode} { + if {!$opt_expand_right && !$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 @@ -1130,7 +1140,6 @@ tcl::namespace::eval overtype { 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" @@ -1433,7 +1442,7 @@ tcl::namespace::eval overtype { #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 rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $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] @@ -1584,7 +1593,7 @@ tcl::namespace::eval overtype { set overflowlength [expr {$overtext_datalen - $renderwidth}] 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 rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -expand_right $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] @@ -1632,8 +1641,8 @@ tcl::namespace::eval overtype { } 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] + #Note - we still need expand_right 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 -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] #puts stderr "--> [ansistring VIEW -lf 1 -nul 1 $rinfo] <--" set overflow_right [tcl::dict::get $rinfo overflow_right] set unapplied [tcl::dict::get $rinfo unapplied] @@ -1655,7 +1664,8 @@ tcl::namespace::eval overtype { #-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) + #(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? + # This would probably be impractical to support for different fonts) #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} { @@ -1677,8 +1687,10 @@ tcl::namespace::eval overtype { #[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. + #puts stderr "renderline '$args'" + if {[llength $args] < 2} { - error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-overflow [1|0]? undertext overtext} + error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} } lassign [lrange $args end-1 end] under over if {[string first \n $under] >= 0} { @@ -1692,7 +1704,7 @@ tcl::namespace::eval overtype { set opts [tcl::dict::create\ -etabs 0\ -width \uFFEF\ - -overflow 0\ + -expand_right 0\ -transparent 0\ -startcolumn 1\ -cursor_column 1\ @@ -1713,13 +1725,13 @@ tcl::namespace::eval overtype { #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 + #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency, currsor movements to 2nd charcol, or overflow/expand_right #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 + -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { tcl::dict::set opts $k $v @@ -1732,7 +1744,7 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- --- --- --- --- 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_expand_right [tcl::dict::get $opts -expand_right] 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] @@ -1752,17 +1764,7 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- --- --- --- --- 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] @@ -1852,7 +1854,7 @@ tcl::namespace::eval overtype { 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 pt_underchars "" ;#for string_columns length calculation for expand_right 0 truncation set remainder [list] ;#for returnextra foreach {pt code} $undermap { #pt = plain text @@ -1996,47 +1998,25 @@ tcl::namespace::eval overtype { #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] - } - } + #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] } - } 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 {[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 renderwidth $opt_width } else { @@ -2127,8 +2107,10 @@ tcl::namespace::eval overtype { lappend overlay_grapheme_control_stacks $o_codestack } } else { + set tsbegin [clock micros] foreach grapheme_original [punk::char::grapheme_split $pt] { set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] + #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" foreach grapheme [punk::char::grapheme_split $pt_crm] { if {$grapheme eq "\n"} { lappend overlay_grapheme_control_stacks $o_codestack @@ -2142,6 +2124,8 @@ tcl::namespace::eval overtype { } } } + set elapsed [expr {[clock micros] - $tsbegin}] + puts stderr "ptlen [string length $pt] elapsedus:$elapsed" } #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc @@ -2259,11 +2243,12 @@ tcl::namespace::eval overtype { # -- --- --- #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. + if {$opt_expand_right} { + #expand_right 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. + #we currently only support horizontal expansion to the right (review regarding RTL text!) set overflow_idx -1 } else { - #overflow zero - we can't grow beyond our column width - so we get ellipsis or truncation + #expand_right 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 { @@ -2304,7 +2289,7 @@ tcl::namespace::eval overtype { #movements only occur within the overlay range. #an underlay is however not necessary.. e.g - #renderline -overflow 1 "" data + #renderline -expand_right 1 "" data #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} @@ -2331,7 +2316,7 @@ tcl::namespace::eval overtype { g { set ch $item #crm_mode affects both graphic and control - if {$crm_mode} { + if {0 && $crm_mode} { set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] set chars [string map [list \n "\x1b\[00001E"] $chars] if {[llength [split $chars ""]] > 1} { @@ -2376,7 +2361,7 @@ tcl::namespace::eval overtype { #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 overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 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 @@ -2384,7 +2369,10 @@ tcl::namespace::eval overtype { #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 + if {$idx == -1 || $overflow_idx > $idx} { + #don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 + } set instruction lf_mid priv::render_unapplied $overlay_grapheme_control_list $gci break @@ -2466,23 +2454,35 @@ tcl::namespace::eval overtype { #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 + #REVIEW + set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control + lassign $next_gc next_type next_item + if {$autowrap_mode || $next_type ne "g"} { + 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 { + #no point throwing back to caller for each grapheme that is overflowing + #without this branch - renderline would be called with overtext reducing only by one grapheme per call + #processing a potentially long overtext each time (ie - very slow) + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #JMN4 + + } } } 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) + #overflow_idx = -1 + #This corresponds to expand_right 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])} { + 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 " " @@ -2621,7 +2621,7 @@ tcl::namespace::eval overtype { } incr idx } - if {($cursor_column < [llength $outcols]) || $overflow_idx == -1 || $test_mode} { + if {($cursor_column < [llength $outcols]) || $overflow_idx == -1} { incr cursor_column } } elseif {$uwidth > 1} { @@ -2655,12 +2655,6 @@ tcl::namespace::eval overtype { 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] - } - } } } } @@ -2704,6 +2698,7 @@ tcl::namespace::eval overtype { set leadernorm [tcl::string::range [tcl::string::map [list\ \x1b\[< 1006\ \x1b\[ 7CSI\ + \x1bP 7DCS\ \x9b 8CSI\ \x1b\] 7OSC\ \x9d 8OSC\ @@ -2720,6 +2715,11 @@ tcl::namespace::eval overtype { 7CSI - 7OSC { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] } + 7DCS { + #ESC P + #Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74 + 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]] } @@ -2812,7 +2812,7 @@ tcl::namespace::eval overtype { if {$overflow_idx == -1} { incr max } - if {$test_mode && $cursor_column == $max+1} { + if {$cursor_column == $max+1} { #move_forward while in overflow incr cursor_column -1 } @@ -2829,7 +2829,7 @@ tcl::namespace::eval overtype { } #horizontal movement beyond line extent needs to wrap - throw back to caller - #we may have both overflow_rightand unapplied data + #we may have both overflow_right and 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 @@ -2844,7 +2844,8 @@ tcl::namespace::eval overtype { } } } else { - if {!$opt_overflow || ($cursor_column + $num) <= [llength $outcols+1]} { + #review - dead branch + if {!$expand_right || ($cursor_column + $num) <= [llength $outcols+1]} { incr idx $num incr cursor_column $num } else { @@ -3052,55 +3053,99 @@ tcl::namespace::eval overtype { } } J { - puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of screen - } - 1 { - #clear from cursor to beginning of screen - } - 2 { - #clear entire screen - #ansi.sys - move cursor to upper left REVIEW - set cursor_row 1 - set cursor_column 1 - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - } - 3 { - #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? - + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + #CSI ? Pn J - selective erase + puts stderr "overtype::renderline ED - SELECTIVE ERASE IN DISPLAY (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" } default { + puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of screen + } + 1 { + #clear from cursor to beginning of screen + } + 2 { + #clear entire screen + #ansi.sys - move cursor to upper left REVIEW + set cursor_row 1 + set cursor_column 1 + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + } + 3 { + #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? + + } + default { + } + } + } } - } K { - puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of line - } - 1 { - #clear from cursor to beginning of line + #see DECECM regarding background colour + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param [string range $param 1 end] ;#chop qmark + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line - depending on DECSCA + } + 1 { + #clear from cursor to beginning of line - depending on DECSCA + + } + 2 { + #clear entire line - depending on DECSCA + } + default { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } - } - 2 { - #clear entire line } default { - puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line + } + 1 { + #clear from cursor to beginning of line + + } + 2 { + #clear entire line + } + default { + puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } } } } + L { + puts stderr "overtype::renderline IL - Insert Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + M { + #CSI Pn M - DL - Delete Line + puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + } X { puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param" #ECH - erase character @@ -3108,6 +3153,36 @@ tcl::namespace::eval overtype { priv::render_erasechar $idx $param #cursor position doesn't change. } + q { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + {"} { + #DECSCA - Select Character Protection Attribute + #(for use with selective erase: DECSED and DECSEL) + set param [tcl::string::range $codenorm 4 end-2] + if {$param eq ""} {set param 0} + #TODO - store like SGR in stacks - replays? + switch -exact -- $param { + 0 - 2 { + #canerase + puts stderr "overtype::renderline - DECSCA canerase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 1 { + #cannoterase + puts stderr "overtype::renderline - DECSCA cannoterase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline DECSCA param '$param' not understood [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + puts stderr "overtype::renderline - CSI ... q not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } r { #$re_decstbm #https://www.vt100.net/docs/vt510-rm/DECSTBM.html @@ -3279,72 +3354,97 @@ tcl::namespace::eval overtype { set instruction restore_cursor break } + "{" { + + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + "}" { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + ' { + puts stderr "renderline warning - DECIC - Insert Column - CSI...' - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + default { + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + } + } ~ { - #$re_vt_sequence - 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 + set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ + switch -exact -- $code_secondlast { + ' { + #DECDC - editing sequence - Delete Column + puts stderr "renderline warning - DECDC - unimplemented" } - } 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(?) + default { + #$re_vt_sequence + 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 } + } - } 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 } } @@ -3358,51 +3458,72 @@ tcl::namespace::eval overtype { set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = switch -exact -- $modegroup { ? { - set num [tcl::string::range $codenorm 5 end-1] ;#param between ? and h|l - 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 - - if {$code_end eq "h"} { - #set (enable) - set reverse_mode 1 - } else { - #reset (disable) - set reverse_mode 0 + set smparams [tcl::string::range $codenorm 5 end-1] ;#params between ? and h|l + #one or more modes can be set + set smparam_list [split $smparams {;}] + foreach num $smparam_list { + switch -- $num { + "" { + #ignore empties e.g extra/trailing semicolon in params } - - } - 7 { - #DECAWM autowrap - if {$code_end eq "h"} { - #set (enable) - set autowrap_mode 1 - if {$opt_width ne "\uFFEF"} { - set overflow_idx $opt_width + 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 + + if {$code_end eq "h"} { + #set (enable) + set reverse_mode 1 } 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 + #reset (disable) + set reverse_mode 0 } - #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" + + } + 7 { + #DECAWM autowrap + if {$code_end 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 usually - but sanity check with warning for now. + if {$idx >= $overflow_idx} { + puts stderr "renderline warning - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" + } + } else { + #reset (disable) + set autowrap_mode 0 + #REVIEW! + set overflow_idx -1 } - } else { - #reset (disable) - set autowrap_mode 0 - set overflow_idx -1 } - } - 25 { - if {$code_end eq "h"} { - #visible cursor + 25 { + if {$code_end eq "h"} { + #visible cursor - } else { - #invisible cursor + } else { + #invisible cursor + } + } + 117 { + #DECECM - Erase Color Mode + #https://invisible-island.net/ncurses/ncurses.faq.html + #The Erase color selection controls the background color used when text is erased or new + #text is scrolled on to the screen. Screen background causes newly erased areas or + #scrolled text to be written using color index zero, the screen background. This is VT + #and DECterm compatible. Text background causes erased areas or scrolled text to be + #written using the current text background color. This is PC console compatible and is + #the factory default. + + #see also: https://unix.stackexchange.com/questions/251726/clear-to-end-of-line-uses-the-wrong-background-color-in-screen } } } @@ -3422,8 +3543,21 @@ tcl::namespace::eval overtype { # #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 #https://vt100.net/docs/vt510-rm/CRM.html + #NOTE - vt100 CRM always does auto-wrap at right margin. + #disabling auto-wrap in set-up or by sequence is disabled. + #We should default to turning off auto-wrap when crm_mode enabled.. but + #displaying truncated (on rhs) crm can still be very useful - and we have optimisation in overflow to avoid excess renderline calls (per grapheme) + #we therefore could reasonably put in an exception to allow auto_wrap to be disabled after crm_mode is engaged, + #although this would be potentially an annoying difference to some.. REVIEW if {$code_end eq "h"} { set crm_mode 1 + 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 + } } else { set crm_mode 0 } @@ -3431,8 +3565,10 @@ tcl::namespace::eval overtype { 4 { #IRM - Insert/Replace Mode if {$code_end eq "h"} { + #CSI 4 h set insert_mode 1 } else { + #CSI 4 l #replace mode set insert_mode 0 } @@ -3480,25 +3616,49 @@ tcl::namespace::eval overtype { } } 7ESC { + # #re_other_single {\x1b(D|M|E)$} #also PM \x1b^...(ST) switch -- [tcl::string::index $codenorm 4] { + c { + #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! + puts stderr "renderline reset" + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction reset + break + } 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" + puts stderr "renderline ESC D not fully implemented" incr cursor_row priv::render_unapplied $overlay_grapheme_control_list $gci set instruction 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 "overtype::renderline ESC E unimplemented" + + } + H { + #\x88 + #Tab Set + puts stderr "overtype::renderline ESC H tab set unimplemented" + } 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" + puts stderr "overtype::renderline ESC M not fully implemented" set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #move up @@ -3512,17 +3672,39 @@ tcl::namespace::eval overtype { #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" + N { + #\x8e - affects next character only + puts stderr "overtype::renderline single shift select G2 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + O { + #\x8f - affects next character only + puts stderr "overtype::renderline single shift select G3 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + P { + #\x90 + #DCS - shouldn't get here - handled in 7DCS branch + #similarly \] OSC (\x9d) and \\ (\x9c) ST + } + V { + #\x96 } + W { + #\x97 + } + X { + #\x98 + #SOS + if {[string index $code end] eq "\007"} { + set sos_content [string range $code 2 end-1] ;#ST is \007 + } else { + set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ + } + #return in some useful form to the caller + #TODO! + lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] + puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } ^ { #puts stderr "renderline PM" #Privacy Message. @@ -3550,24 +3732,6 @@ tcl::namespace::eval overtype { #lappend to a dict element in the result for application-specific processing lappend pm_list $pm_content } - N - O { - puts stderr "overtype::renderline single shift command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - P { - puts stderr "overtype::renderline DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - X { - #SOS - if {[string index $code end] eq "\007"} { - set sos_content [string range $code 2 end-1] ;#ST is \007 - } else { - set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ - } - #return in some useful form to the caller - #TODO! - lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] - puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } _ { #APC Application Program Command #just warn for now.. @@ -3578,6 +3742,14 @@ tcl::namespace::eval overtype { } } + } + 7DCS { + puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + # + + } + 7OSC - 8OSC { + } default { } @@ -3593,7 +3765,7 @@ tcl::namespace::eval overtype { } #-------- - if {$opt_overflow == 0} { + if {$opt_expand_right == 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 @@ -3774,13 +3946,14 @@ tcl::namespace::eval overtype { cursor_saved_attributes $cursor_saved_attributes\ cursor_column $cursor_column\ cursor_row $cursor_row\ - opt_overflow $opt_overflow\ + expand_right $opt_expand_right\ replay_codes $replay_codes\ replay_codes_underlay $replay_codes_underlay\ replay_codes_overlay $replay_codes_overlay\ pm_list $pm_list\ ] if {$opt_returnextra == 1} { + #puts stderr "renderline: $result" return $result } else { #human/debug - map special chars to visual glyphs @@ -3805,6 +3978,7 @@ tcl::namespace::eval overtype { return $result } } else { + #puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right" return $outstring } #return [join $out ""] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index 7a2f944..267e680 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -106,7 +106,7 @@ tcl::namespace::eval punk::ansi::class { #overflow is a different concept - perhaps not particularly congruent with the idea of the textblock as a mini terminal emulator. #overflow effectively auto-expands the block(terminal?) width #overflow and wrap both being true won't make sense unless we implement a max_overflow concept - set o_rendered [overtype::renderspace -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] + set o_rendered [overtype::renderspace -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] if {$cksum eq "not-done"} { #if dimensions changed - the checksum won't have been done set o_rendered_what [$o_ansistringobj checksum] @@ -129,7 +129,7 @@ tcl::namespace::eval punk::ansi::class { set o_dimensions $dimensions - set rendered [overtype::renderspace -experimental {test_mode} -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] + set rendered [overtype::renderspace -cp437 1 -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] return $rendered } method render_to_input_line {args} { @@ -176,7 +176,7 @@ tcl::namespace::eval punk::ansi::class { if {$opt_minus ne "0"} { set chunk [tcl::string::range $chunk 0 end-$opt_minus] } - set rendered [overtype::renderspace -experimental {test_mode} -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk] + set rendered [overtype::renderspace -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk] set marker "" for {set i 1} {$i <= $w} {incr i} { if {$i % 10 == 0} { @@ -514,11 +514,8 @@ tcl::namespace::eval punk::ansi { set encnames [encoding names] set encoding "" set dimensions "" - set test_mode 0 foreach a $args { - if {$a eq "test_mode"} { - set test_mode 1 - } elseif {$a in $encnames} { + if {$a in $encnames} { set encoding $a } else { if {[regexp {[0-9]+(?:x|X)[0-9]+} $a]} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index 6368aea..4dd7bd6 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -1021,8 +1021,8 @@ namespace eval punk::console { #It's known this isn't always the case - but things like textutil::untabify2 take only a single value #on some systems test_char_width is a similar speed to get_tabstop_apparent_width - but on some test_char_width is much slower #we will use test_char_width as a fallback - proc get_tabstop_apparent_width {} { - set tslist [get_tabstops] + proc get_tabstop_apparent_width {{inoutchannels {stdin stdout}}} { + set tslist [get_tabstops $inoutchannels] if {![llength $tslist]} { #either terminal failed to report - or none set. set testw [test_char_width \t] @@ -1199,7 +1199,7 @@ namespace eval punk::console { } if {!$emit} { - puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1 + puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line, 1G cursor at col1 } set response "" if {[catch { @@ -1429,12 +1429,12 @@ namespace eval punk::console { proc cursor_save {} { #*** !doctools #[call [fun cursor_save]] - puts -nonewline \x1b\[s + puts -nonewline stdout \x1b\[s } proc cursor_restore {} { #*** !doctools #[call [fun cursor_restore]] - puts -nonewline \x1b\[u + puts -nonewline stdout \x1b\[u } #DEC equivalents of cursor_save/cursor_restore - perhaps more widely supported? proc cursor_save_dec {} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.0.tm new file mode 100644 index 0000000..628419f --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.0.tm @@ -0,0 +1,632 @@ +# -*- 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.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::zip 0 0.1.0] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require 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 [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] + if {[llength $subdir]>0} { + set result [concat $result $dir $subdir] + } + } + return $result + } + + # Mkzipfile -- + # + # FIX ME: should handle the current offset for non-seekable channels + # + proc Mkzipfile {zipchan base path {comment ""}} { + #*** !doctools + #[call [fun Mkzipfile] [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 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 offset [tell $zipchan] + 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 $offset + 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 $offset] + append hdr $utfpath $extra $utfcomment + return $hdr + } + # zip::mkzip -- + # + # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt + # + proc mkzip {args} { + #*** !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 + -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 "" + -runtime -default "" -help "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + " + -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" + -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + *values -min 1 -max -1 + filename -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 -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 ""} { + set rt [open $opts(-runtime) rb] + fcopy $rt $zf + close $rt + } elseif {$opts(-zipkit)} { + 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 + } + set count 0 + set cd "" + + set members [list] + foreach path $paths { + #puts $path + lappend members $path + append cd [Mkzipfile $zf $base $path] ;#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.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.1.tm index 5d127a3..88fdc3f 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.1.tm @@ -1933,13 +1933,6 @@ tcl::namespace::eval textblock { set hval $ansibase_header$header ;#no reset set rowh [my header_height $hrow] - #set h_lines [lrepeat $rowh $hcell_line_blank] - #set hcell_blank [join $h_lines \n] - #set hval_lines [split $hval \n] - #set hval_lines [lrange $hval_lines 0 $rowh-1] - #set hval_block [join $hval_lines \n] - #set headercell [overtype::left -experimental test_mode $ansibase_header$hcell_blank$RST $hval_block] - if {$hrow == 0} { set hlims $header_boxlimits_toprow set rowpos "top" @@ -2146,7 +2139,7 @@ tcl::namespace::eval textblock { #puts $hblock #puts "==>hval:'$hval'[a]" #puts "==>hval:'[ansistring VIEW $hval]'" - #set spanned_frame [overtype::renderspace -experimental test_mode -transparent 1 $spanned_frame $hblock] + #set spanned_frame [overtype::renderspace -transparent 1 $spanned_frame $hblock] #spanned values default left - todo make configurable @@ -3504,11 +3497,11 @@ tcl::namespace::eval textblock { 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 -overflow 1 -experimental test_mode -transparent $TSUB $table[unset table] $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 -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol] + #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] } incr padwidth $bodywidth incr colposn @@ -3609,14 +3602,7 @@ tcl::namespace::eval textblock { 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}] -overflow 1 -experimental test_mode -transparent $TSUB $table $nextcol] - - #set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] - #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent $TSUB $table[unset table] $nextcol] - #JMN - - #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] - #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol] + set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] } incr padwidth $bodywidth incr colposn @@ -3726,7 +3712,7 @@ tcl::namespace::eval textblock { lappend body_blocks $nextcol_body } else { if {$headerheight > 0} { - set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -overflow 1 -experimental test_mode -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] + 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] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config index 490025b..75a091d 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config @@ -57,6 +57,7 @@ set bootsupport_modules [list\ modules punk::path\ modules punk::repo\ modules punk::tdl\ + modules punk::zip\ modules punk::winpath\ modules textblock\ modules oolib\ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/logger-0.9.5.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/logger-0.9.5.tm new file mode 100644 index 0000000..739e1c9 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/logger-0.9.5.tm @@ -0,0 +1,1297 @@ +# logger.tcl -- +# +# Tcl implementation of a general logging facility. +# +# Copyright (c) 2003 by David N. Welton +# Copyright (c) 2004-2011 by Michael Schlenker +# Copyright (c) 2006,2015 by Andreas Kupries +# +# See the file license.terms. + +# The logger package provides an 'object oriented' log facility that +# lets you have trees of services, that inherit from one another. +# This is accomplished through the use of Tcl namespaces. + + +package require Tcl 8.5 9 +package provide logger 0.9.5 + +namespace eval ::logger { + namespace eval tree {} + namespace export init enable disable services servicecmd import + + # The active services. + variable services {} + + # The log 'levels'. + variable levels [list debug info notice warn error critical alert emergency] + + # The default global log level used for new logging services + variable enabled "debug" + + # Tcl return codes (in numeric order) + variable RETURN_CODES [list "ok" "error" "return" "break" "continue"] +} + +# Try to load msgcat and fall back to format if it fails +if {[catch {package require msgcat}]} { + interp alias {} ::logger::mc {} ::format +} else { + namespace eval ::logger { + namespace import ::msgcat::mc + } +} + +# ::logger::_nsExists -- +# +# Workaround for missing namespace exists in Tcl 8.2 and 8.3. +# + +if {[package vcompare [package provide Tcl] 8.4] < 0} { + proc ::logger::_nsExists {ns} { + expr {![catch {namespace parent $ns}]} + } +} else { + proc ::logger::_nsExists {ns} { + namespace exists $ns + } +} + +# ::logger::_cmdPrefixExists -- +# +# Utility function to check if a given callback prefix exists, +# this should catch all oddities in prefix names, including spaces, +# glob patterns, non normalized namespaces etc. +# +# Arguments: +# prefix - The command prefix to check +# +# Results: +# 1 or 0 for yes or no +# +proc ::logger::_cmdPrefixExists {prefix} { + set cmd [lindex $prefix 0] + set full [namespace eval :: namespace which [list $cmd]] + if {[string equal $full ""]} {return 0} else {return 1} + # normalize namespaces + set ns [namespace qualifiers $cmd] + set cmd ${ns}::[namespace tail $cmd] + set matches [::info commands ${ns}::*] + if {[lsearch -exact $matches $cmd] != -1} {return 1} + return 0 +} + +# ::logger::walk -- +# +# Walk namespaces, starting in 'start', and evaluate 'code' in +# them. +# +# Arguments: +# start - namespace to start in. +# code - code to execute in namespaces walked. +# +# Side Effects: +# Side effects of code executed. +# +# Results: +# None. + +proc ::logger::walk { start code } { + set children [namespace children $start] + foreach c $children { + logger::walk $c $code + namespace eval $c $code + } +} + +proc ::logger::init {service} { + variable levels + variable services + variable enabled + + if {[string length [string trim $service {:}]] == 0} { + return -code error \ + -errorcode [list LOGGER EMPTY_SERVICENAME] \ + [::logger::mc "Service name invalid. May not consist only of : or be empty"] + } + # We create a 'tree' namespace to house all the services, so + # they are in a 'safe' namespace sandbox, and won't overwrite + # any commands. + namespace eval tree::${service} { + variable service + variable levels + variable oldname + variable enabled + } + + lappend services $service + + set [namespace current]::tree::${service}::service $service + set [namespace current]::tree::${service}::levels $levels + set [namespace current]::tree::${service}::oldname $service + set [namespace current]::tree::${service}::enabled $enabled + + namespace eval tree::${service} { + # Callback to use when the service in question is shut down. + variable delcallback [namespace current]::no-op + + # Callback when the loglevel is changed + variable levelchangecallback [namespace current]::no-op + + # State variable to decide when to call levelcallback + variable inSetLevel 0 + + # The currently configured levelcommands + variable lvlcmds + array set lvlcmds {} + + # List of procedures registered via the trace command + variable traceList "" + + # Flag indicating whether or not tracing is currently enabled + variable tracingEnabled 0 + + # We use this to disable a service completely. In Tcl 8.4 + # or greater, by using this, disabled log calls are a + # no-op! + + proc no-op args {} + + proc stdoutcmd {level text} { + variable service + puts "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'" + } + + proc stderrcmd {level text} { + variable service + puts stderr "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'" + } + + + # setlevel -- + # + # This command differs from enable and disable in that + # it disables all the levels below that selected, and + # then enables all levels above it, which enable/disable + # do not do. + # + # Arguments: + # lv - the level, as defined in $levels. + # + # Side Effects: + # Runs disable for the level, and then enable, in order + # to ensure that all levels are set correctly. + # + # Results: + # None. + + + proc setlevel {lv} { + variable inSetLevel 1 + set oldlvl [currentloglevel] + + # do not allow enable and disable to do recursion + if {[catch { + disable $lv 0 + set newlvl [enable $lv 0] + } msg] == 1} { + return -code error -errorcode $::errorCode $msg + } + # do the recursion here + logger::walk [namespace current] [list setlevel $lv] + + set inSetLevel 0 + lvlchangewrapper $oldlvl $newlvl + return + } + + # enable -- + # + # Enable a particular 'level', and above, for the + # service, and its 'children'. + # + # Arguments: + # lv - the level, as defined in $levels. + # + # Side Effects: + # Enables logging for the particular level, and all + # above it (those more important). It also walks + # through all services that are 'children' and enables + # them at the same level or above. + # + # Results: + # None. + + proc enable {lv {recursion 1}} { + variable levels + set lvnum [lsearch -exact $levels $lv] + if { $lvnum == -1 } { + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] + } + + variable enabled + set newlevel $enabled + set elnum [lsearch -exact $levels $enabled] + if {($elnum == -1) || ($elnum > $lvnum)} { + set newlevel $lv + } + + variable service + while { $lvnum < [llength $levels] } { + interp alias {} [namespace current]::[lindex $levels $lvnum] \ + {} [namespace current]::[lindex $levels $lvnum]cmd + incr lvnum + } + + if {$recursion} { + logger::walk [namespace current] [list enable $lv] + } + lvlchangewrapper $enabled $newlevel + set enabled $newlevel + } + + # disable -- + # + # Disable a particular 'level', and below, for the + # service, and its 'children'. + # + # Arguments: + # lv - the level, as defined in $levels. + # + # Side Effects: + # Disables logging for the particular level, and all + # below it (those less important). It also walks + # through all services that are 'children' and disables + # them at the same level or below. + # + # Results: + # None. + + proc disable {lv {recursion 1}} { + variable levels + set lvnum [lsearch -exact $levels $lv] + if { $lvnum == -1 } { + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] + } + + variable enabled + set newlevel $enabled + set elnum [lsearch -exact $levels $enabled] + if {($elnum > -1) && ($elnum <= $lvnum)} { + if {$lvnum+1 >= [llength $levels]} { + set newlevel "none" + } else { + set newlevel [lindex $levels [expr {$lvnum+1}]] + } + } + + while { $lvnum >= 0 } { + + interp alias {} [namespace current]::[lindex $levels $lvnum] {} \ + [namespace current]::no-op + incr lvnum -1 + } + if {$recursion} { + logger::walk [namespace current] [list disable $lv] + } + lvlchangewrapper $enabled $newlevel + set enabled $newlevel + } + + # currentloglevel -- + # + # Get the currently enabled log level for this service. + # + # Arguments: + # none + # + # Side Effects: + # none + # + # Results: + # current log level + # + + proc currentloglevel {} { + variable enabled + return $enabled + } + + # lvlchangeproc -- + # + # Set or introspect a callback for when the logger instance + # changes its loglevel. + # + # Arguments: + # cmd - the Tcl command to call, it is called with two parameters, old and new log level. + # or none for introspection + # + # Side Effects: + # None. + # + # Results: + # If no arguments are given return the current callback cmd. + + proc lvlchangeproc {args} { + variable levelchangecallback + + switch -exact -- [llength [::info level 0]] { + 1 {return $levelchangecallback} + 2 { + if {[::logger::_cmdPrefixExists [lindex $args 0]]} { + set levelchangecallback [lindex $args 0] + } else { + return -code error \ + -errorcode [list LOGGER INVALID_CMD] \ + [::logger::mc "Invalid cmd '%s' - does not exist" [lindex $args 0]] + } + } + default { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "Wrong # of arguments. Usage: \${log}::lvlchangeproc ?cmd?"] + } + } + } + + proc lvlchangewrapper {old new} { + variable inSetLevel + + # we are called after disable and enable are finished + if {$inSetLevel} {return} + + # no action if level does not change + if {[string equal $old $new]} {return} + + variable levelchangecallback + # no action if levelchangecallback isn't a valid command + if {[::logger::_cmdPrefixExists $levelchangecallback]} { + catch { + uplevel \#0 [linsert $levelchangecallback end $old $new] + } + } + } + + # logproc -- + # + # Command used to create a procedure that is executed to + # perform the logging. This could write to disk, out to + # the network, or something else. + # If two arguments are given, use an existing command. + # If three arguments are given, create a proc. + # + # Arguments: + # lv - the level to log, which must be one of $levels. + # args - either zero, one or two arguments. + # if zero this returns the current command registered + # if one, this is a cmd name that is called for this level + # if two, these are an argument and proc body + # + # Side Effects: + # Creates a logging command to take care of the details + # of logging an event. + # + # Results: + # If called with zero length args, returns the name of the currently + # configured logging procedure. + # + # + + proc logproc {lv args} { + variable levels + variable lvlcmds + + set lvnum [lsearch -exact $levels $lv] + if { ($lvnum == -1) && ($lv != "trace") } { + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] + } + switch -exact -- [llength $args] { + 0 { + return $lvlcmds($lv) + } + 1 { + set cmd [lindex $args 0] + if {[string equal "[namespace current]::${lv}cmd" $cmd]} {return} + if {[llength [::info commands $cmd]]} { + proc ${lv}cmd args [format { + uplevel 1 [list %s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] + } $cmd] + } else { + return -code error \ + -errorcode [list LOGGER INVALID_CMD] \ + [::logger::mc "Invalid cmd '%s' - does not exist" $cmd] + } + set lvlcmds($lv) $cmd + } + 2 { + foreach {arg body} $args {break} + proc ${lv}cmd args [format {\ + _setservicename args + set val [%s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] + _restoreservice + set val} ${lv}customcmd] + proc ${lv}customcmd $arg $body + set lvlcmds($lv) [namespace current]::${lv}customcmd + } + default { + return -code error \ + -errorcode [list LOGGER WRONG_USAGE] \ + [::logger::mc \ + "Usage: \${log}::logproc level ?cmd?\nor \${log}::logproc level argname body" ] + } + } + } + + + # delproc -- + # + # Set or introspect a callback for when the logger instance + # is deleted. + # + # Arguments: + # cmd - the Tcl command to call. + # or none for introspection + # + # Side Effects: + # None. + # + # Results: + # If no arguments are given return the current callback cmd. + + proc delproc {args} { + variable delcallback + + switch -exact -- [llength [::info level 0]] { + 1 {return $delcallback} + 2 { if {[::logger::_cmdPrefixExists [lindex $args 0]]} { + set delcallback [lindex $args 0] + } else { + return -code error \ + -errorcode [list LOGGER INVALID_CMD] \ + [::logger::mc "Invalid cmd '%s' - does not exist" [lindex $args 0]] + } + } + default { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "Wrong # of arguments. Usage: \${log}::delproc ?cmd?"] + } + } + } + + + # delete -- + # + # Delete the namespace and its children. + + proc delete {} { + variable delcallback + variable service + + logger::walk [namespace current] delete + if {[::logger::_cmdPrefixExists $delcallback]} { + uplevel \#0 [lrange $delcallback 0 end] + } + # clean up the global services list + set idx [lsearch -exact [logger::services] $service] + if {$idx !=-1} { + set ::logger::services [lreplace [logger::services] $idx $idx] + } + + namespace delete [namespace current] + + } + + # services -- + # + # Return all child services + + proc services {} { + variable service + + set children [list] + foreach srv [logger::services] { + if {[string match "${service}::*" $srv]} { + lappend children $srv + } + } + return $children + } + + # servicename -- + # + # Return the name of the service + + proc servicename {} { + variable service + return $service + } + + proc _setservicename {argname} { + variable service + variable oldname + upvar 1 $argname arg + if {[llength $arg] <= 1} { + return + } + + set count -1 + set newname "" + while {[string equal [lindex $arg [expr {$count+1}]] "-_logger::service"]} { + incr count 2 + set newname [lindex $arg $count] + } + if {[string equal $newname ""]} { + return + } + set oldname $service + set service $newname + # Pop off "-_logger::service " from argument list + set arg [lreplace $arg 0 $count] + } + + proc _restoreservice {} { + variable service + variable oldname + set service $oldname + return + } + + proc trace { action args } { + variable service + + # Allow other boolean values (true, false, yes, no, 0, 1) to be used + # as synonymns for "on" and "off". + + if {[string is boolean $action]} { + set xaction [expr {($action && 1) ? "on" : "off"}] + } else { + set xaction $action + } + + # Check for required arguments for actions/subcommands and dispatch + # to the appropriate procedure. + + switch -- $xaction { + "status" { + return [uplevel 1 [list logger::_trace_status $service $args]] + } + "on" { + if {[llength $args]} { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace on\""] + } + return [logger::_trace_on $service] + } + "off" { + if {[llength $args]} { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace off\""] + } + return [logger::_trace_off $service] + } + "add" { + if {![llength $args]} { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace add ?-ns? ...\""] + } + return [uplevel 1 [list ::logger::_trace_add $service $args]] + } + "remove" { + if {![llength $args]} { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace remove ?-ns? ...\""] + } + return [uplevel 1 [list ::logger::_trace_remove $service $args]] + } + + default { + return -code error \ + -errorcode [list LOGGER INVALID_ARG] \ + [::logger::mc "Invalid action \"%s\": must be status, add, remove,\ + on, or off" $action] + } + } + } + + # Walk the parent service namespaces to see first, if they + # exist, and if any are enabled, and then, as a + # consequence, enable this one + # too. + + enable $enabled + variable parent [namespace parent] + while {[string compare $parent "::logger::tree"]} { + # If the 'enabled' variable doesn't exist, create the + # whole thing. + if { ! [::info exists ${parent}::enabled] } { + logger::init [string range $parent 16 end] + } + set enabled [set ${parent}::enabled] + enable $enabled + set parent [namespace parent $parent] + } + } + + # Now create the commands for different levels. + + namespace eval tree::${service} { + set parent [namespace parent] + + # We 'inherit' the commands from the parents. This + # means that, if you want to share the same methods with + # children, they should be instantiated after the parent's + # methods have been defined. + + variable lvl ; # prevent creative writing to the global scope + if {[string compare $parent "::logger::tree"]} { + foreach lvl [::logger::levels] { + # OPTIMIZE: do not allow multiple aliases in the hierarchy + # they can always be replaced by more efficient + # direct aliases to the target procs. + interp alias {} [namespace current]::${lvl}cmd \ + {} ${parent}::${lvl}cmd -_logger::service $service + } + # inherit the starting loglevel of the parent service + setlevel [${parent}::currentloglevel] + } else { + foreach lvl [concat [::logger::levels] "trace"] { + proc ${lvl}cmd args [format {\ + _setservicename args + set val [stdoutcmd %s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] + _restoreservice + set val } $lvl] + + set lvlcmds($lvl) [namespace current]::${lvl}cmd + } + setlevel $::logger::enabled + } + unset lvl ; # drop the temp iteration variable + } + + return ::logger::tree::${service} +} + +# ::logger::services -- +# +# Returns a list of all active services. +# +# Arguments: +# None. +# +# Side Effects: +# None. +# +# Results: +# List of active services. + +proc ::logger::services {} { + variable services + return $services +} + +# ::logger::enable -- +# +# Global enable for a certain level. NOTE - this implementation +# isn't terribly effective at the moment, because it might hit +# children before their parents, who will then walk down the +# tree attempting to disable the children again. +# +# Arguments: +# lv - level above which to enable logging. +# +# Side Effects: +# Enables logging in a given level, and all higher levels. +# +# Results: +# None. + +proc ::logger::enable {lv} { + variable services + if {[catch { + foreach sv $services { + ::logger::tree::${sv}::enable $lv + } + } msg] == 1} { + return -code error -errorcode $::errorCode $msg + } +} + +proc ::logger::disable {lv} { + variable services + if {[catch { + foreach sv $services { + ::logger::tree::${sv}::disable $lv + } + } msg] == 1} { + return -code error -errorcode $::errorCode $msg + } +} + +proc ::logger::setlevel {lv} { + variable services + variable enabled + variable levels + if {[lsearch -exact $levels $lv] == -1} { + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] + } + set enabled $lv + if {[catch { + foreach sv $services { + ::logger::tree::${sv}::setlevel $lv + } + } msg] == 1} { + return -code error -errorcode $::errorCode $msg + } +} + +# ::logger::levels -- +# +# Introspect the available log levels. Provided so a caller does +# not need to know implementation details or code the list +# himself. +# +# Arguments: +# None. +# +# Side Effects: +# None. +# +# Results: +# levels - The list of valid log levels accepted by enable and disable + +proc ::logger::levels {} { + variable levels + return $levels +} + +# ::logger::servicecmd -- +# +# Get the command token for a given service name. +# +# Arguments: +# service - name of the service. +# +# Side Effects: +# none +# +# Results: +# log - namespace token for this service + +proc ::logger::servicecmd {service} { + variable services + if {[lsearch -exact $services $service] == -1} { + return -code error \ + -errorcode [list LOGGER NO_SUCH_SERVICE] \ + [::logger::mc "Service \"%s\" does not exist." $service] + } + return "::logger::tree::${service}" +} + +# ::logger::import -- +# +# Import the logging commands. +# +# Arguments: +# service - name of the service. +# +# Side Effects: +# creates aliases in the target namespace +# +# Results: +# none + +proc ::logger::import {args} { + variable services + + if {[llength $args] == 0 || [llength $args] > 7} { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc \ + "Wrong # of arguments: \"logger::import ?-all?\ + ?-force?\ + ?-prefix prefix? ?-namespace namespace? service\""] + } + + # process options + # + set import_all 0 + set force 0 + set prefix "" + set ns [uplevel 1 namespace current] + while {[llength $args] > 1} { + set opt [lindex $args 0] + set args [lrange $args 1 end] + switch -exact -- $opt { + -all { set import_all 1} + -prefix { set prefix [lindex $args 0] + set args [lrange $args 1 end] + } + -namespace { + set ns [lindex $args 0] + set args [lrange $args 1 end] + } + -force { + set force 1 + } + default { + return -code error \ + -errorcode [list LOGGER UNKNOWN_ARG] \ + [::logger::mc \ + "Unknown argument: \"%s\" :\nUsage:\ + \"logger::import ?-all? ?-force?\ + ?-prefix prefix? ?-namespace namespace? service\"" $opt] + } + } + } + + # + # build the list of commands to import + # + + set cmds [logger::levels] + lappend cmds "trace" + if {$import_all} { + lappend cmds setlevel enable disable logproc delproc services + lappend cmds servicename currentloglevel delete + } + + # + # check the service argument + # + + set service [lindex $args 0] + if {[lsearch -exact $services $service] == -1} { + return -code error \ + -errorcode [list LOGGER NO_SUCH_SERVICE] \ + [::logger::mc "Service \"%s\" does not exist." $service] + } + + # + # setup the namespace for the import + # + + set sourcens [logger::servicecmd $service] + set localns [uplevel 1 namespace current] + + if {[string match ::* $ns]} { + set importns $ns + } else { + set importns ${localns}::$ns + } + + # fake namespace exists for Tcl 8.2 - 8.3 + if {![_nsExists $importns]} { + namespace eval $importns {} + } + + + # + # prepare the import + # + + set imports "" + foreach cmd $cmds { + set cmdname ${importns}::${prefix}$cmd + set collision [llength [info commands $cmdname]] + if {$collision && !$force} { + return -code error \ + -errorcode [list LOGGER IMPORT_NAME_EXISTS] \ + [::logger::mc "can't import command \"%s\": already exists" $cmdname] + } + lappend imports ${importns}::${prefix}$cmd ${sourcens}::${cmd} + } + + # + # and execute the aliasing after checking all is well + # + + foreach {target source} $imports { + proc $target {args} "uplevel 1 \[linsert \$args 0 $source \]" + } +} + +# ::logger::initNamespace -- +# +# Creates a logger for the specified namespace and makes the log +# commands available to said namespace as well. Allows the initial +# setting of a default log level. +# +# Arguments: +# ns - Namespace to initialize, is also the service name, modulo a ::-prefix +# level - Initial log level, optional, defaults to 'warn'. +# +# Side Effects: +# creates aliases in the target namespace +# +# Results: +# none + +proc ::logger::initNamespace {ns {level {}}} { + set service [string trimleft $ns :] + if {$level == ""} { + # No user-specified level. Figure something out. + # - If the parent service exists then the 'logger::init' + # below will automatically inherit its level. Good enough. + # - Without a parent service go and use a default level of 'warn'. + set parent [string trimleft [namespace qualifiers $service] :] + set hasparent [expr {($parent != {}) && [_nsExists ::logger::tree::${parent}]}] + if {!$hasparent} { + set level warn + } + } + + namespace eval $ns [list ::logger::init $service] + namespace eval $ns [list ::logger::import -force -all -namespace log $service] + if {$level != ""} { + namespace eval $ns [list log::setlevel $level] + } + return +} + +# This procedure handles the "logger::trace status" command. Given no +# arguments, returns a list of all procedures that have been registered +# via "logger::trace add". Given one or more procedure names, it will +# return 1 if all were registered, or 0 if any were not. + +proc ::logger::_trace_status { service procList } { + upvar #0 ::logger::tree::${service}::traceList traceList + + # If no procedure names were given, just return the registered list + + if {![llength $procList]} { + return $traceList + } + + # Get caller's namespace for qualifying unqualified procedure names + + set caller_ns [uplevel 1 namespace current] + set caller_ns [string trimright $caller_ns ":"] + + # Search for any specified proc names that are *not* registered + + foreach procName $procList { + # Make sure the procedure namespace is qualified + + if {![string match "::*" $procName]} { + set procName ${caller_ns}::$procName + } + + # Check if the procedure has been registered for tracing + + if {[lsearch -exact $traceList $procName] == -1} { + return 0 + } + } + + return 1 +} + +# This procedure handles the "logger::trace on" command. If tracing +# is turned off, it will enable Tcl trace handlers for all of the procedures +# registered via "logger::trace add". Does nothing if tracing is already +# turned on. + +proc ::logger::_trace_on { service } { + set tcl_version [package provide Tcl] + + if {[package vcompare $tcl_version "8.4"] < 0} { + return -code error \ + -errorcode [list LOGGER TRACE_NOT_AVAILABLE] \ + [::logger::mc "execution tracing is not available in Tcl %s" $tcl_version] + } + + namespace eval ::logger::tree::${service} { + if {!$tracingEnabled} { + set tracingEnabled 1 + ::logger::_enable_traces $service $traceList + } + } + + return 1 +} + +# This procedure handles the "logger::trace off" command. If tracing +# is turned on, it will disable Tcl trace handlers for all of the procedures +# registered via "logger::trace add", leaving them in the list so they +# tracing on all of them can be enabled again with "logger::trace on". +# Does nothing if tracing is already turned off. + +proc ::logger::_trace_off { service } { + namespace eval ::logger::tree::${service} { + if {$tracingEnabled} { + ::logger::_disable_traces $service $traceList + set tracingEnabled 0 + } + } + + return 1 +} + +# This procedure is used by the logger::trace add and remove commands to +# process the arguments in a common fashion. If the -ns switch is given +# first, this procedure will return a list of all existing procedures in +# all of the namespaces given in remaining arguments. Otherwise, each +# argument is taken to be either a pattern for a glob-style search of +# procedure names or, failing that, a namespace, in which case this +# procedure returns a list of all the procedures matching the given +# pattern (or all in the named namespace, if no procedures match). + +proc ::logger::_trace_get_proclist { inputList } { + set procList "" + + if {[string equal [lindex $inputList 0] "-ns"]} { + # Verify that at least one target namespace was supplied + + set inputList [lrange $inputList 1 end] + if {![llength $inputList]} { + return -code error \ + -errorcode [list LOGGER TARGET_MISSING] \ + [::logger::mc "Must specify at least one namespace target"] + } + + # Rebuild the argument list to contain namespace procedures + + foreach namespace $inputList { + # Don't allow tracing of the logger (or child) namespaces + + if {![string match "::logger::*" $namespace]} { + set nsProcList [::info procs ${namespace}::*] + set procList [concat $procList $nsProcList] + } + } + } else { + # Search for procs or namespaces matching each of the specified + # patterns. + + foreach pattern $inputList { + set matches [uplevel 1 ::info proc $pattern] + + if {![llength $matches]} { + if {[uplevel 1 namespace exists $pattern]} { + set matches [::info procs ${pattern}::*] + } + + # Matched procs will be qualified due to above pattern + + set procList [concat $procList $matches] + } elseif {[string match "::*" $pattern]} { + # Patterns were pre-qualified - add them directly + + set procList [concat $procList $matches] + } else { + # Qualify each proc with the namespace it was in + + set ns [uplevel 1 namespace current] + if {$ns == "::"} { + set ns "" + } + foreach proc $matches { + lappend procList ${ns}::$proc + } + } + } + } + + return $procList +} + +# This procedure handles the "logger::trace add" command. If the tracing +# feature is enabled, it will enable the Tcl entry and leave trace handlers +# for each procedure specified that isn't already being traced. Each +# procedure is added to the list of procedures that the logger trace feature +# should log when tracing is enabled. + +proc ::logger::_trace_add { service procList } { + upvar #0 ::logger::tree::${service}::traceList traceList + + # Handle -ns switch and glob search patterns for procedure names + + set procList [uplevel 1 [list logger::_trace_get_proclist $procList]] + + # Enable tracing for each procedure that has not previously been + # specified via logger::trace add. If tracing is off, this will just + # store the name of the procedure for later when tracing is turned on. + + foreach procName $procList { + if {[lsearch -exact $traceList $procName] == -1} { + lappend traceList $procName + ::logger::_enable_traces $service [list $procName] + } + } +} + +# This procedure handles the "logger::trace remove" command. If the tracing +# feature is enabled, it will remove the Tcl entry and leave trace handlers +# for each procedure specified. Each procedure is removed from the list +# of procedures that the logger trace feature should log when tracing is +# enabled. + +proc ::logger::_trace_remove { service procList } { + upvar #0 ::logger::tree::${service}::traceList traceList + + # Handle -ns switch and glob search patterns for procedure names + + set procList [uplevel 1 [list logger::_trace_get_proclist $procList]] + + # Disable tracing for each proc that previously had been specified + # via logger::trace add. If tracing is off, this will just + # remove the name of the procedure from the trace list so that it + # will be excluded when tracing is turned on. + + foreach procName $procList { + set index [lsearch -exact $traceList $procName] + if {$index != -1} { + set traceList [lreplace $traceList $index $index] + ::logger::_disable_traces $service [list $procName] + } + } +} + +# This procedure enables Tcl trace handlers for all procedures specified. +# It is used both to enable Tcl's tracing for a single procedure when +# removed via "logger::trace add", as well as to enable all traces +# via "logger::trace on". + +proc ::logger::_enable_traces { service procList } { + upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled + + if {$tracingEnabled} { + foreach procName $procList { + ::trace add execution $procName enter \ + [list ::logger::_trace_enter $service] + ::trace add execution $procName leave \ + [list ::logger::_trace_leave $service] + } + } +} + +# This procedure disables Tcl trace handlers for all procedures specified. +# It is used both to disable Tcl's tracing for a single procedure when +# removed via "logger::trace remove", as well as to disable all traces +# via "logger::trace off". + +proc ::logger::_disable_traces { service procList } { + upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled + + if {$tracingEnabled} { + foreach procName $procList { + ::trace remove execution $procName enter \ + [list ::logger::_trace_enter $service] + ::trace remove execution $procName leave \ + [list ::logger::_trace_leave $service] + } + } +} + +######################################################################## +# Trace Handlers +######################################################################## + +# This procedure is invoked upon entry into a procedure being traced +# via "logger::trace add" when tracing is enabled via "logger::trace on" +# to log information about how the procedure was called. + +proc ::logger::_trace_enter { service cmd op } { + # Parse the command + set procName [uplevel 1 namespace origin [lindex $cmd 0]] + set args [lrange $cmd 1 end] + + # Display the message prefix + set callerLvl [expr {[::info level] - 1}] + set calledLvl [::info level] + + lappend message "proc" $procName + lappend message "level" $calledLvl + lappend message "script" [uplevel ::info script] + + # Display the caller information + set caller "" + if {$callerLvl >= 1} { + # Display the name of the caller proc w/prepended namespace + catch { + set callerProcName [lindex [::info level $callerLvl] 0] + set caller [uplevel 2 namespace origin $callerProcName] + } + } + + lappend message "caller" $caller + + # Display the argument names and values + set argSpec [uplevel 1 ::info args $procName] + set argList "" + if {[llength $argSpec]} { + foreach argName $argSpec { + lappend argList $argName + + if {$argName == "args"} { + lappend argList $args + break + } else { + lappend argList [lindex $args 0] + set args [lrange $args 1 end] + } + } + } + + lappend message "procargs" $argList + set message [list $op $message] + + ::logger::tree::${service}::tracecmd $message +} + +# This procedure is invoked upon leaving into a procedure being traced +# via "logger::trace add" when tracing is enabled via "logger::trace on" +# to log information about the result of the procedure call. + +proc ::logger::_trace_leave { service cmd status rc op } { + variable RETURN_CODES + + # Parse the command + set procName [uplevel 1 namespace origin [lindex $cmd 0]] + + # Gather the caller information + set callerLvl [expr {[::info level] - 1}] + set calledLvl [::info level] + + lappend message "proc" $procName "level" $calledLvl + lappend message "script" [uplevel ::info script] + + # Get the name of the proc being returned to w/prepended namespace + set caller "" + catch { + set callerProcName [lindex [::info level $callerLvl] 0] + set caller [uplevel 2 namespace origin $callerProcName] + } + + lappend message "caller" $caller + + # Convert the return code from numeric to verbal + + if {$status < [llength $RETURN_CODES]} { + set status [lindex $RETURN_CODES $status] + } + + lappend message "status" $status + lappend message "result" $rc + + # Display the leave message + + set message [list $op $message] + ::logger::tree::${service}::tracecmd $message + + return 1 +} + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm index f7e4c1a..38ce71c 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm @@ -165,16 +165,17 @@ tcl::namespace::eval overtype::priv { #could return larger than renderwidth proc _get_row_append_column {row} { + #obsolete? upvar outputlines outputlines set idx [expr {$row -1}] if {$row <= 1 || $row > [llength $outputlines]} { return 1 } else { - upvar opt_overflow opt_overflow + upvar opt_expand_right expand_right upvar renderwidth renderwidth set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] set endpos [expr {$existinglen +1}] - if {$opt_overflow} { + if {$expand_right} { return $endpos } else { if {$endpos > $renderwidth} { @@ -204,14 +205,14 @@ tcl::namespace::eval overtype { 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 + #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [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: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} } set optargs [lrange $args 0 end-2] if {[llength $optargs] % 2 == 0} { @@ -228,30 +229,46 @@ tcl::namespace::eval overtype { } } set opts [tcl::dict::create\ - -bias ignored\ - -width \uFFEF\ - -height \uFFEF\ + -bias ignored\ + -width \uFFEF\ + -height \uFFEF\ -startcolumn 1\ - -wrap 0\ - -ellipsis 0\ + -wrap 0\ + -ellipsis 0\ -ellipsistext $default_ellipsis_horizontal\ -ellipsiswhitespace 0\ - -overflow 0\ - -appendlines 1\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -experimental 0\ - -looplimit \uFFEF\ - -crm_mode 0\ - -reverse_mode 0\ + -expand_right 0\ + -appendlines 1\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -experimental 0\ + -cp437 1\ + -looplimit \uFFEF\ + -crm_mode 0\ + -reverse_mode 0\ + -insert_mode 0\ + -console {stdin stdout stderr}\ ] + #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. + # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) + # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. + # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. + # - further implication is that if expand_right grows the virtual renderspace terminal width - + # then some sort of reflow/rerender needs to be done for preceeding lines? + # possibly not - as expand_right is distinct from a normal terminal-width change event, + # expand_right being primarily to support other operations such as textblock::table + + #todo - viewport width/height as separate concept to terminal width/height? #-ellipsis args not used if -wrap is true foreach {k v} $argsflags { switch -- $k { - -looplimit - -width - -height - -startcolumn - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -appendlines + -looplimit - -width - -height - -startcolumn - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -transparent - -exposed1 - -exposed2 - -experimental - - -reverse_mode - -crm_mode { + - -expand_right - -appendlines + - -reverse_mode - -crm_mode - -insert_mode + - -cp437 + - -console { tcl::dict::set opts $k $v } default { @@ -261,7 +278,8 @@ tcl::namespace::eval overtype { } #set opts [tcl::dict::merge $defaults $argsflags] # -- --- --- --- --- --- - set opt_overflow [tcl::dict::get $opts -overflow] + #review - expand_left for RTL text? + set opt_expand_right [tcl::dict::get $opts -expand_right] ##### # 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) @@ -279,23 +297,31 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- set opt_crm_mode [tcl::dict::get $opts -crm_mode] set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] + set opt_insert_mode [tcl::dict::get $opts -insert_mode] + # -- --- --- --- --- --- + set opt_cp437 [tcl::dict::get $opts -cp437] + + + #initial state for renderspace 'terminal' reset + set initial_state [dict create\ + -width $opt_width\ + -height $opt_height\ + -crm_mode $opt_crm_mode\ + -reverse_mode $opt_reverse_mode\ + -insert_mode $opt_insert_mode\ + -cp437 $opt_cp437\ + ] # ---------------------------- # -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 { @@ -309,11 +335,10 @@ tcl::namespace::eval overtype { } } } - 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 insert_mode $opt_insert_mode ;#can be toggled by insert key or ansi IRM sequence ESC [ 4 h|l set autowrap_mode $opt_wrap set reverse_mode $opt_reverse_mode set crm_mode $opt_crm_mode @@ -377,49 +402,45 @@ tcl::namespace::eval overtype { 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] + 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 } - 1 { - set inputchunks [punk::ansi::ta::split_codes $overblock] + } + 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 } - 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 - } + if {[llength $lflines]} { + lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] } - 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] + set inputchunks $lflines[unset lflines] - } } } @@ -441,11 +462,11 @@ tcl::namespace::eval overtype { #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 { + #if {$data_mode} { + # set col [_get_row_append_column $row] + #} else { set col $opt_startcolumn - } + #} set instruction_stats [tcl::dict::create] @@ -473,33 +494,27 @@ tcl::namespace::eval overtype { } #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\ - -crm_mode $crm_mode\ - -autowrap_mode $autowrap_mode\ - -reverse_mode $reverse_mode\ - -transparent $opt_transparent\ - -width $renderwidth\ - -exposed1 $opt_exposed1\ - -exposed2 $opt_exposed2\ - -overflow $opt_overflow -cursor_column $col -cursor_row $row $undertext $overtext] - set rinfo [renderline -experimental $opt_experimental\ + set renderargs [list -experimental $opt_experimental\ + -cp437 $opt_cp437\ -info 1\ -crm_mode $crm_mode\ -insert_mode $insert_mode\ -autowrap_mode $autowrap_mode\ - -reverse_mode $reverse_mode\ + -reverse_mode $reverse_mode\ -cursor_restore_attributes $cursor_saved_attributes\ -transparent $opt_transparent\ -width $renderwidth\ -exposed1 $opt_exposed1\ -exposed2 $opt_exposed2\ - -overflow $opt_overflow\ + -expand_right $opt_expand_right\ -cursor_column $col\ -cursor_row $row\ $undertext\ $overtext\ - ] + ] + set LASTCALL $renderargs + set rinfo [renderline {*}$renderargs] + 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] ;# @@ -523,6 +538,7 @@ tcl::namespace::eval overtype { #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] if {0 && $reverse_mode} { + #test branch - todo - prune puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" #review #JMN3 @@ -579,29 +595,17 @@ tcl::namespace::eval overtype { #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 > $renderwidth} { + reset { + #reset the 'renderspace terminal' (not underlying terminal) + set row 1 + set col 1 - } - } 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 - #} - } + } + {} { + #lf included in data + set row $post_render_row + set col $post_render_col } up { @@ -704,7 +708,14 @@ tcl::namespace::eval overtype { puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" - set sub_info [overtype::renderline -info 1 -width $renderwidth -insert_mode $insert_mode -autowrap_mode $autowrap_mode -overflow [tcl::dict::get $opts -overflow] "" $overflow_right] + set sub_info [overtype::renderline -info 1\ + -width $renderwidth\ + -insert_mode $insert_mode\ + -autowrap_mode $autowrap_mode\ + -expand_right [tcl::dict::get $opts -opt_expand_right]\ + ""\ + $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.. @@ -735,7 +746,7 @@ tcl::namespace::eval overtype { #overflow + unapplied? } lf_start { - #raw newlines - must be test_mode + #raw newlines # ---------------------- #test with fruit.ans #test - treating as newline below... @@ -751,48 +762,58 @@ tcl::namespace::eval overtype { } 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 edit_mode 0 + if {$edit_mode} { + set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] set overflow_right "" - - - set row $renderedrow - + set unapplied "" + set row $post_render_row + #set col $post_render_col 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 "" + if 1 { + if {$overflow_right ne ""} { + if {$opt_expand_right} { + append rendered $overflow_right + set overflow_right "" + } else { + set overflow_width [punk::ansi::printing_length $overflow_right] + if {$visualwidth + $overflow_width <= $renderwidth} { + append rendered $overflow_right + set overflow_right "" + } else { + if {$visualwidth < $renderwidth} { + set graphemes [punk::char::grapheme_split $overflow_width] + set add "" + set addlen $visualwidth + set remaining_overflow $graphemes + foreach g $graphemes { + set w [overtype::grapheme_width_cached] + if {$addlen + $w <= $renderwidth} { + append add $g + incr addlen $w + lpop remaining_overflow + } else { + break + } + } + append rendered $add + set overflow_right [join $remaining_overflow ""] + } + } + } + } set row $post_render_row - #set col $post_render_col set col $opt_startcolumn if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } } else { + #old version - known to work with various ansi graphics - e.g fruit.ans + # - but fails to limit lines to renderwidth when expand_right == 0 append rendered $overflow_right set overflow_right "" set row $post_render_row @@ -851,38 +872,28 @@ tcl::namespace::eval overtype { 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 + #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 @@ -974,7 +985,6 @@ tcl::namespace::eval overtype { 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] @@ -1052,7 +1062,7 @@ tcl::namespace::eval overtype { } - if {!$opt_overflow && !$autowrap_mode} { + if {!$opt_expand_right && !$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 @@ -1130,7 +1140,6 @@ tcl::namespace::eval overtype { 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" @@ -1433,7 +1442,7 @@ tcl::namespace::eval overtype { #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 rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $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] @@ -1584,7 +1593,7 @@ tcl::namespace::eval overtype { set overflowlength [expr {$overtext_datalen - $renderwidth}] 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 rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -expand_right $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] @@ -1632,8 +1641,8 @@ tcl::namespace::eval overtype { } 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] + #Note - we still need expand_right 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 -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] #puts stderr "--> [ansistring VIEW -lf 1 -nul 1 $rinfo] <--" set overflow_right [tcl::dict::get $rinfo overflow_right] set unapplied [tcl::dict::get $rinfo unapplied] @@ -1655,7 +1664,8 @@ tcl::namespace::eval overtype { #-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) + #(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? + # This would probably be impractical to support for different fonts) #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} { @@ -1677,8 +1687,10 @@ tcl::namespace::eval overtype { #[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. + #puts stderr "renderline '$args'" + if {[llength $args] < 2} { - error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-overflow [1|0]? undertext overtext} + error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} } lassign [lrange $args end-1 end] under over if {[string first \n $under] >= 0} { @@ -1692,7 +1704,7 @@ tcl::namespace::eval overtype { set opts [tcl::dict::create\ -etabs 0\ -width \uFFEF\ - -overflow 0\ + -expand_right 0\ -transparent 0\ -startcolumn 1\ -cursor_column 1\ @@ -1713,13 +1725,13 @@ tcl::namespace::eval overtype { #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 + #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency, currsor movements to 2nd charcol, or overflow/expand_right #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 + -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { tcl::dict::set opts $k $v @@ -1732,7 +1744,7 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- --- --- --- --- 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_expand_right [tcl::dict::get $opts -expand_right] 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] @@ -1752,17 +1764,7 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- --- --- --- --- 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] @@ -1852,7 +1854,7 @@ tcl::namespace::eval overtype { 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 pt_underchars "" ;#for string_columns length calculation for expand_right 0 truncation set remainder [list] ;#for returnextra foreach {pt code} $undermap { #pt = plain text @@ -1996,47 +1998,25 @@ tcl::namespace::eval overtype { #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] - } - } + #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] } - } 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 {[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 renderwidth $opt_width } else { @@ -2127,8 +2107,10 @@ tcl::namespace::eval overtype { lappend overlay_grapheme_control_stacks $o_codestack } } else { + set tsbegin [clock micros] foreach grapheme_original [punk::char::grapheme_split $pt] { set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] + #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" foreach grapheme [punk::char::grapheme_split $pt_crm] { if {$grapheme eq "\n"} { lappend overlay_grapheme_control_stacks $o_codestack @@ -2142,6 +2124,8 @@ tcl::namespace::eval overtype { } } } + set elapsed [expr {[clock micros] - $tsbegin}] + puts stderr "ptlen [string length $pt] elapsedus:$elapsed" } #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc @@ -2259,11 +2243,12 @@ tcl::namespace::eval overtype { # -- --- --- #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. + if {$opt_expand_right} { + #expand_right 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. + #we currently only support horizontal expansion to the right (review regarding RTL text!) set overflow_idx -1 } else { - #overflow zero - we can't grow beyond our column width - so we get ellipsis or truncation + #expand_right 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 { @@ -2304,7 +2289,7 @@ tcl::namespace::eval overtype { #movements only occur within the overlay range. #an underlay is however not necessary.. e.g - #renderline -overflow 1 "" data + #renderline -expand_right 1 "" data #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} @@ -2331,7 +2316,7 @@ tcl::namespace::eval overtype { g { set ch $item #crm_mode affects both graphic and control - if {$crm_mode} { + if {0 && $crm_mode} { set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] set chars [string map [list \n "\x1b\[00001E"] $chars] if {[llength [split $chars ""]] > 1} { @@ -2376,7 +2361,7 @@ tcl::namespace::eval overtype { #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 overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 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 @@ -2384,7 +2369,10 @@ tcl::namespace::eval overtype { #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 + if {$idx == -1 || $overflow_idx > $idx} { + #don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 + } set instruction lf_mid priv::render_unapplied $overlay_grapheme_control_list $gci break @@ -2466,23 +2454,35 @@ tcl::namespace::eval overtype { #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 + #REVIEW + set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control + lassign $next_gc next_type next_item + if {$autowrap_mode || $next_type ne "g"} { + 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 { + #no point throwing back to caller for each grapheme that is overflowing + #without this branch - renderline would be called with overtext reducing only by one grapheme per call + #processing a potentially long overtext each time (ie - very slow) + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #JMN4 + + } } } 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) + #overflow_idx = -1 + #This corresponds to expand_right 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])} { + 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 " " @@ -2621,7 +2621,7 @@ tcl::namespace::eval overtype { } incr idx } - if {($cursor_column < [llength $outcols]) || $overflow_idx == -1 || $test_mode} { + if {($cursor_column < [llength $outcols]) || $overflow_idx == -1} { incr cursor_column } } elseif {$uwidth > 1} { @@ -2655,12 +2655,6 @@ tcl::namespace::eval overtype { 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] - } - } } } } @@ -2704,6 +2698,7 @@ tcl::namespace::eval overtype { set leadernorm [tcl::string::range [tcl::string::map [list\ \x1b\[< 1006\ \x1b\[ 7CSI\ + \x1bP 7DCS\ \x9b 8CSI\ \x1b\] 7OSC\ \x9d 8OSC\ @@ -2720,6 +2715,11 @@ tcl::namespace::eval overtype { 7CSI - 7OSC { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] } + 7DCS { + #ESC P + #Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74 + 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]] } @@ -2812,7 +2812,7 @@ tcl::namespace::eval overtype { if {$overflow_idx == -1} { incr max } - if {$test_mode && $cursor_column == $max+1} { + if {$cursor_column == $max+1} { #move_forward while in overflow incr cursor_column -1 } @@ -2829,7 +2829,7 @@ tcl::namespace::eval overtype { } #horizontal movement beyond line extent needs to wrap - throw back to caller - #we may have both overflow_rightand unapplied data + #we may have both overflow_right and 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 @@ -2844,7 +2844,8 @@ tcl::namespace::eval overtype { } } } else { - if {!$opt_overflow || ($cursor_column + $num) <= [llength $outcols+1]} { + #review - dead branch + if {!$expand_right || ($cursor_column + $num) <= [llength $outcols+1]} { incr idx $num incr cursor_column $num } else { @@ -3052,55 +3053,99 @@ tcl::namespace::eval overtype { } } J { - puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of screen - } - 1 { - #clear from cursor to beginning of screen - } - 2 { - #clear entire screen - #ansi.sys - move cursor to upper left REVIEW - set cursor_row 1 - set cursor_column 1 - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - } - 3 { - #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? - + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + #CSI ? Pn J - selective erase + puts stderr "overtype::renderline ED - SELECTIVE ERASE IN DISPLAY (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" } default { + puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of screen + } + 1 { + #clear from cursor to beginning of screen + } + 2 { + #clear entire screen + #ansi.sys - move cursor to upper left REVIEW + set cursor_row 1 + set cursor_column 1 + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + } + 3 { + #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? + + } + default { + } + } + } } - } K { - puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of line - } - 1 { - #clear from cursor to beginning of line + #see DECECM regarding background colour + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param [string range $param 1 end] ;#chop qmark + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line - depending on DECSCA + } + 1 { + #clear from cursor to beginning of line - depending on DECSCA + + } + 2 { + #clear entire line - depending on DECSCA + } + default { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } - } - 2 { - #clear entire line } default { - puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line + } + 1 { + #clear from cursor to beginning of line + + } + 2 { + #clear entire line + } + default { + puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } } } } + L { + puts stderr "overtype::renderline IL - Insert Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + M { + #CSI Pn M - DL - Delete Line + puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + } X { puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param" #ECH - erase character @@ -3108,6 +3153,36 @@ tcl::namespace::eval overtype { priv::render_erasechar $idx $param #cursor position doesn't change. } + q { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + {"} { + #DECSCA - Select Character Protection Attribute + #(for use with selective erase: DECSED and DECSEL) + set param [tcl::string::range $codenorm 4 end-2] + if {$param eq ""} {set param 0} + #TODO - store like SGR in stacks - replays? + switch -exact -- $param { + 0 - 2 { + #canerase + puts stderr "overtype::renderline - DECSCA canerase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 1 { + #cannoterase + puts stderr "overtype::renderline - DECSCA cannoterase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline DECSCA param '$param' not understood [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + puts stderr "overtype::renderline - CSI ... q not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } r { #$re_decstbm #https://www.vt100.net/docs/vt510-rm/DECSTBM.html @@ -3279,72 +3354,97 @@ tcl::namespace::eval overtype { set instruction restore_cursor break } + "{" { + + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + "}" { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + ' { + puts stderr "renderline warning - DECIC - Insert Column - CSI...' - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + default { + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + } + } ~ { - #$re_vt_sequence - 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 + set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ + switch -exact -- $code_secondlast { + ' { + #DECDC - editing sequence - Delete Column + puts stderr "renderline warning - DECDC - unimplemented" } - } 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(?) + default { + #$re_vt_sequence + 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 } + } - } 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 } } @@ -3358,51 +3458,72 @@ tcl::namespace::eval overtype { set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = switch -exact -- $modegroup { ? { - set num [tcl::string::range $codenorm 5 end-1] ;#param between ? and h|l - 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 - - if {$code_end eq "h"} { - #set (enable) - set reverse_mode 1 - } else { - #reset (disable) - set reverse_mode 0 + set smparams [tcl::string::range $codenorm 5 end-1] ;#params between ? and h|l + #one or more modes can be set + set smparam_list [split $smparams {;}] + foreach num $smparam_list { + switch -- $num { + "" { + #ignore empties e.g extra/trailing semicolon in params } - - } - 7 { - #DECAWM autowrap - if {$code_end eq "h"} { - #set (enable) - set autowrap_mode 1 - if {$opt_width ne "\uFFEF"} { - set overflow_idx $opt_width + 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 + + if {$code_end eq "h"} { + #set (enable) + set reverse_mode 1 } 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 + #reset (disable) + set reverse_mode 0 } - #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" + + } + 7 { + #DECAWM autowrap + if {$code_end 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 usually - but sanity check with warning for now. + if {$idx >= $overflow_idx} { + puts stderr "renderline warning - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" + } + } else { + #reset (disable) + set autowrap_mode 0 + #REVIEW! + set overflow_idx -1 } - } else { - #reset (disable) - set autowrap_mode 0 - set overflow_idx -1 } - } - 25 { - if {$code_end eq "h"} { - #visible cursor + 25 { + if {$code_end eq "h"} { + #visible cursor - } else { - #invisible cursor + } else { + #invisible cursor + } + } + 117 { + #DECECM - Erase Color Mode + #https://invisible-island.net/ncurses/ncurses.faq.html + #The Erase color selection controls the background color used when text is erased or new + #text is scrolled on to the screen. Screen background causes newly erased areas or + #scrolled text to be written using color index zero, the screen background. This is VT + #and DECterm compatible. Text background causes erased areas or scrolled text to be + #written using the current text background color. This is PC console compatible and is + #the factory default. + + #see also: https://unix.stackexchange.com/questions/251726/clear-to-end-of-line-uses-the-wrong-background-color-in-screen } } } @@ -3422,8 +3543,21 @@ tcl::namespace::eval overtype { # #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 #https://vt100.net/docs/vt510-rm/CRM.html + #NOTE - vt100 CRM always does auto-wrap at right margin. + #disabling auto-wrap in set-up or by sequence is disabled. + #We should default to turning off auto-wrap when crm_mode enabled.. but + #displaying truncated (on rhs) crm can still be very useful - and we have optimisation in overflow to avoid excess renderline calls (per grapheme) + #we therefore could reasonably put in an exception to allow auto_wrap to be disabled after crm_mode is engaged, + #although this would be potentially an annoying difference to some.. REVIEW if {$code_end eq "h"} { set crm_mode 1 + 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 + } } else { set crm_mode 0 } @@ -3431,8 +3565,10 @@ tcl::namespace::eval overtype { 4 { #IRM - Insert/Replace Mode if {$code_end eq "h"} { + #CSI 4 h set insert_mode 1 } else { + #CSI 4 l #replace mode set insert_mode 0 } @@ -3480,25 +3616,49 @@ tcl::namespace::eval overtype { } } 7ESC { + # #re_other_single {\x1b(D|M|E)$} #also PM \x1b^...(ST) switch -- [tcl::string::index $codenorm 4] { + c { + #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! + puts stderr "renderline reset" + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction reset + break + } 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" + puts stderr "renderline ESC D not fully implemented" incr cursor_row priv::render_unapplied $overlay_grapheme_control_list $gci set instruction 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 "overtype::renderline ESC E unimplemented" + + } + H { + #\x88 + #Tab Set + puts stderr "overtype::renderline ESC H tab set unimplemented" + } 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" + puts stderr "overtype::renderline ESC M not fully implemented" set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #move up @@ -3512,17 +3672,39 @@ tcl::namespace::eval overtype { #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" + N { + #\x8e - affects next character only + puts stderr "overtype::renderline single shift select G2 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + O { + #\x8f - affects next character only + puts stderr "overtype::renderline single shift select G3 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + P { + #\x90 + #DCS - shouldn't get here - handled in 7DCS branch + #similarly \] OSC (\x9d) and \\ (\x9c) ST + } + V { + #\x96 } + W { + #\x97 + } + X { + #\x98 + #SOS + if {[string index $code end] eq "\007"} { + set sos_content [string range $code 2 end-1] ;#ST is \007 + } else { + set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ + } + #return in some useful form to the caller + #TODO! + lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] + puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } ^ { #puts stderr "renderline PM" #Privacy Message. @@ -3550,24 +3732,6 @@ tcl::namespace::eval overtype { #lappend to a dict element in the result for application-specific processing lappend pm_list $pm_content } - N - O { - puts stderr "overtype::renderline single shift command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - P { - puts stderr "overtype::renderline DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - X { - #SOS - if {[string index $code end] eq "\007"} { - set sos_content [string range $code 2 end-1] ;#ST is \007 - } else { - set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ - } - #return in some useful form to the caller - #TODO! - lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] - puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } _ { #APC Application Program Command #just warn for now.. @@ -3578,6 +3742,14 @@ tcl::namespace::eval overtype { } } + } + 7DCS { + puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + # + + } + 7OSC - 8OSC { + } default { } @@ -3593,7 +3765,7 @@ tcl::namespace::eval overtype { } #-------- - if {$opt_overflow == 0} { + if {$opt_expand_right == 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 @@ -3774,13 +3946,14 @@ tcl::namespace::eval overtype { cursor_saved_attributes $cursor_saved_attributes\ cursor_column $cursor_column\ cursor_row $cursor_row\ - opt_overflow $opt_overflow\ + expand_right $opt_expand_right\ replay_codes $replay_codes\ replay_codes_underlay $replay_codes_underlay\ replay_codes_overlay $replay_codes_overlay\ pm_list $pm_list\ ] if {$opt_returnextra == 1} { + #puts stderr "renderline: $result" return $result } else { #human/debug - map special chars to visual glyphs @@ -3805,6 +3978,7 @@ tcl::namespace::eval overtype { return $result } } else { + #puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right" return $outstring } #return [join $out ""] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index 7a2f944..267e680 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -106,7 +106,7 @@ tcl::namespace::eval punk::ansi::class { #overflow is a different concept - perhaps not particularly congruent with the idea of the textblock as a mini terminal emulator. #overflow effectively auto-expands the block(terminal?) width #overflow and wrap both being true won't make sense unless we implement a max_overflow concept - set o_rendered [overtype::renderspace -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] + set o_rendered [overtype::renderspace -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] if {$cksum eq "not-done"} { #if dimensions changed - the checksum won't have been done set o_rendered_what [$o_ansistringobj checksum] @@ -129,7 +129,7 @@ tcl::namespace::eval punk::ansi::class { set o_dimensions $dimensions - set rendered [overtype::renderspace -experimental {test_mode} -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] + set rendered [overtype::renderspace -cp437 1 -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] return $rendered } method render_to_input_line {args} { @@ -176,7 +176,7 @@ tcl::namespace::eval punk::ansi::class { if {$opt_minus ne "0"} { set chunk [tcl::string::range $chunk 0 end-$opt_minus] } - set rendered [overtype::renderspace -experimental {test_mode} -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk] + set rendered [overtype::renderspace -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk] set marker "" for {set i 1} {$i <= $w} {incr i} { if {$i % 10 == 0} { @@ -514,11 +514,8 @@ tcl::namespace::eval punk::ansi { set encnames [encoding names] set encoding "" set dimensions "" - set test_mode 0 foreach a $args { - if {$a eq "test_mode"} { - set test_mode 1 - } elseif {$a in $encnames} { + if {$a in $encnames} { set encoding $a } else { if {[regexp {[0-9]+(?:x|X)[0-9]+} $a]} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index 6368aea..4dd7bd6 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -1021,8 +1021,8 @@ namespace eval punk::console { #It's known this isn't always the case - but things like textutil::untabify2 take only a single value #on some systems test_char_width is a similar speed to get_tabstop_apparent_width - but on some test_char_width is much slower #we will use test_char_width as a fallback - proc get_tabstop_apparent_width {} { - set tslist [get_tabstops] + proc get_tabstop_apparent_width {{inoutchannels {stdin stdout}}} { + set tslist [get_tabstops $inoutchannels] if {![llength $tslist]} { #either terminal failed to report - or none set. set testw [test_char_width \t] @@ -1199,7 +1199,7 @@ namespace eval punk::console { } if {!$emit} { - puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1 + puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line, 1G cursor at col1 } set response "" if {[catch { @@ -1429,12 +1429,12 @@ namespace eval punk::console { proc cursor_save {} { #*** !doctools #[call [fun cursor_save]] - puts -nonewline \x1b\[s + puts -nonewline stdout \x1b\[s } proc cursor_restore {} { #*** !doctools #[call [fun cursor_restore]] - puts -nonewline \x1b\[u + puts -nonewline stdout \x1b\[u } #DEC equivalents of cursor_save/cursor_restore - perhaps more widely supported? proc cursor_save_dec {} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.0.tm new file mode 100644 index 0000000..628419f --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.0.tm @@ -0,0 +1,632 @@ +# -*- 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.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::zip 0 0.1.0] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require 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 [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] + if {[llength $subdir]>0} { + set result [concat $result $dir $subdir] + } + } + return $result + } + + # Mkzipfile -- + # + # FIX ME: should handle the current offset for non-seekable channels + # + proc Mkzipfile {zipchan base path {comment ""}} { + #*** !doctools + #[call [fun Mkzipfile] [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 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 offset [tell $zipchan] + 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 $offset + 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 $offset] + append hdr $utfpath $extra $utfcomment + return $hdr + } + # zip::mkzip -- + # + # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt + # + proc mkzip {args} { + #*** !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 + -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 "" + -runtime -default "" -help "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + " + -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" + -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + *values -min 1 -max -1 + filename -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 -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 ""} { + set rt [open $opts(-runtime) rb] + fcopy $rt $zf + close $rt + } elseif {$opts(-zipkit)} { + 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 + } + set count 0 + set cd "" + + set members [list] + foreach path $paths { + #puts $path + lappend members $path + append cd [Mkzipfile $zf $base $path] ;#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.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.1.tm index 5d127a3..88fdc3f 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.1.tm @@ -1933,13 +1933,6 @@ tcl::namespace::eval textblock { set hval $ansibase_header$header ;#no reset set rowh [my header_height $hrow] - #set h_lines [lrepeat $rowh $hcell_line_blank] - #set hcell_blank [join $h_lines \n] - #set hval_lines [split $hval \n] - #set hval_lines [lrange $hval_lines 0 $rowh-1] - #set hval_block [join $hval_lines \n] - #set headercell [overtype::left -experimental test_mode $ansibase_header$hcell_blank$RST $hval_block] - if {$hrow == 0} { set hlims $header_boxlimits_toprow set rowpos "top" @@ -2146,7 +2139,7 @@ tcl::namespace::eval textblock { #puts $hblock #puts "==>hval:'$hval'[a]" #puts "==>hval:'[ansistring VIEW $hval]'" - #set spanned_frame [overtype::renderspace -experimental test_mode -transparent 1 $spanned_frame $hblock] + #set spanned_frame [overtype::renderspace -transparent 1 $spanned_frame $hblock] #spanned values default left - todo make configurable @@ -3504,11 +3497,11 @@ tcl::namespace::eval textblock { 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 -overflow 1 -experimental test_mode -transparent $TSUB $table[unset table] $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 -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol] + #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] } incr padwidth $bodywidth incr colposn @@ -3609,14 +3602,7 @@ tcl::namespace::eval textblock { 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}] -overflow 1 -experimental test_mode -transparent $TSUB $table $nextcol] - - #set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] - #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent $TSUB $table[unset table] $nextcol] - #JMN - - #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] - #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol] + set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] } incr padwidth $bodywidth incr colposn @@ -3726,7 +3712,7 @@ tcl::namespace::eval textblock { lappend body_blocks $nextcol_body } else { if {$headerheight > 0} { - set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -overflow 1 -experimental test_mode -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] + 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] diff --git a/src/scriptapps/fetchruntime.ps1 b/src/scriptapps/fetchruntime.ps1 index e6771f0..67dc537 100644 --- a/src/scriptapps/fetchruntime.ps1 +++ b/src/scriptapps/fetchruntime.ps1 @@ -1,5 +1,5 @@ $url = "https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master/win64/tclkit86bi.exe" -$output = "$(join-path $PSScriptRoot "..\src\runtime\tclkit86bi.exe")" +$output = "$(join-path $PSScriptRoot "..\runtime\tclkit86bi.exe")" #padding diff --git a/src/vfs/punk8win.vfs/lib_tcl8/zint-2.13.0/licence.txt b/src/vfs/punk8win.vfs/lib_tcl8/zint-2.13.0/licence.txt deleted file mode 100644 index 795e883..0000000 --- a/src/vfs/punk8win.vfs/lib_tcl8/zint-2.13.0/licence.txt +++ /dev/null @@ -1,14 +0,0 @@ -Copyright (c) 2023 Robin Stuart -All rights reserved. - -Redistribution and use in source and binary forms are permitted -provided that the above copyright notice and this paragraph are -duplicated in all such forms and that any documentation, -advertising materials, and other materials related to such -distribution and use acknowledge that the software was developed -by the . The name of the - may not be used to endorse or promote products derived -from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. diff --git a/src/vfs/punk8win.vfs/lib_tcl8/zint-2.13.0/pkgIndex.tcl b/src/vfs/punk8win.vfs/lib_tcl8/zint-2.13.0/pkgIndex.tcl deleted file mode 100644 index e4c9a07..0000000 --- a/src/vfs/punk8win.vfs/lib_tcl8/zint-2.13.0/pkgIndex.tcl +++ /dev/null @@ -1,2 +0,0 @@ -package ifneeded zint 2.13.0\ - [list load [file join $dir zint[info sharedlibextension]]] diff --git a/src/vfs/punk8win.vfs/lib_tcl8/zint-2.13.0/readme.txt b/src/vfs/punk8win.vfs/lib_tcl8/zint-2.13.0/readme.txt deleted file mode 100644 index 50ede10..0000000 --- a/src/vfs/punk8win.vfs/lib_tcl8/zint-2.13.0/readme.txt +++ /dev/null @@ -1,27 +0,0 @@ - zint tcl binding readme - ----------------------- - 2014-06-30 - (C) Harald Oehlmann - harald.oehlmann@users.sourceforge.net - -What: tcl binding for zint bar code generator library - -Build: -The header files of a TCL and Tk build are required for the build. - -- MS-VC6 project file "zint_tcl.dsp" may be opened by the GUI. - (will need to add your version of tcl/tk libs to LINK32, e.g. - "tcl85.lib" and "tk85.lib") -- Linux/Unix build is provided by the configure script. - Thanks to Christian Werner for that. - -Usage: - -load zint.dll -zint help - -Most options are identical to the command line tool. -Details may be found in the zint manual. - -Demo: -The demo folder contains a visual demo program. diff --git a/src/vfs/punk8win.vfs/lib_tcl8/zint-2.13.0/zint.dll b/src/vfs/punk8win.vfs/lib_tcl8/zint-2.13.0/zint.dll deleted file mode 100644 index fe3578a..0000000 Binary files a/src/vfs/punk8win.vfs/lib_tcl8/zint-2.13.0/zint.dll and /dev/null differ