diff --git a/src/bootsupport/modules/punk/args-0.2.1.tm b/src/bootsupport/modules/punk/args-0.2.1.tm index 3071ebd3..d776aba3 100644 --- a/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/bootsupport/modules/punk/args-0.2.1.tm @@ -11069,8 +11069,8 @@ tcl::namespace::eval punk::args::argdocbase { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::args::package { variable PUNKARGS + # @dynamic not required? lappend PUNKARGS [list { - @dynamic @id -id "::punk::args::package::standard_about" @cmd -name "%pkg%::about" -help\ "About %pkg% diff --git a/src/modules/shellfilter-0.2.tm b/src/bootsupport/modules/shellfilter-0.2.1.tm similarity index 95% rename from src/modules/shellfilter-0.2.tm rename to src/bootsupport/modules/shellfilter-0.2.1.tm index 8017d3f5..7b1098f3 100644 --- a/src/modules/shellfilter-0.2.tm +++ b/src/bootsupport/modules/shellfilter-0.2.1.tm @@ -4,7 +4,7 @@ #Note shellfilter is currently only directly useful for unidirectional channels e.g stdin,stderr,stdout, or for example fifo2 where only one direction is being used. #To generalize this to bidrectional channels would require shifting around read & write methods on transform objects in a very complicated manner. #e.g each transform would probably be a generic transform container which holds sub-objects to which read & write are indirected. -#This is left as a future exercise...possibly it's best left as a concept for uni-directional channels anyway +#This is left as a future exercise...possibly it's best left as a concept for uni-directional channels anyway # - as presumably the reads/writes from a bidirectional channel could be diverted off to unidirectional pipelines for processing with less work # (and maybe even better speed/efficiency if the data volume is asymmetrical and there is significant processing on one direction) # @@ -27,7 +27,7 @@ tcl::namespace::eval shellfilter::log { proc enable {} { variable is_enabled set is_enabled 1 - #'tag' is an identifier for the log source. + #'tag' is an identifier for the log source. # each tag will use it's own thread to write to the configured log target proc ::shellfilter::log::open {tag {settingsdict {}}} { upvar ::shellfilter::sources sourcelist @@ -43,7 +43,7 @@ tcl::namespace::eval shellfilter::log { lappend sourcelist $tag } - #note new_worker + #note new_worker set worker_tid [shellthread::manager::new_worker $tag $settingsdict] #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" return $worker_tid @@ -76,6 +76,7 @@ tcl::namespace::eval shellfilter::log { if {![string length $is_open_required]} { return $allow_adhoc_tags } else { + #why not use string is boolean? set truevalues [list y yes true 1] set falsevalues [list n no false 0] if {[string tolower $is_open_required] in $truevalues} { @@ -115,7 +116,7 @@ namespace eval shellfilter::pipe { #chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation binary ;#works reasonably.. - chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation lf + chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation lf set worker_tid [shellthread::manager::new_pipe_worker $tag_pipename $settingsdict] #puts stderr "worker_tid: $worker_tid" @@ -158,14 +159,14 @@ namespace eval shellfilter::chan { oo::class create var { variable o_datavar - variable o_trecord + variable o_trecord variable o_enc variable o_is_junction constructor {tf} { set o_trecord $tf set o_enc [dict get $tf -encoding] set settingsdict [dict get $tf -settings] - set varname [dict get $settingsdict -varname] + set varname [dict get $settingsdict -varname] set o_datavar $varname if {[dict exists $tf -junction]} { set o_is_junction [dict get $tf -junction] @@ -192,7 +193,7 @@ namespace eval shellfilter::chan { return "" } method meta_is_redirection {} { - return $o_is_junction + return $o_is_junction } method meta_buffering_supported {} { return [list line full none] @@ -202,12 +203,12 @@ namespace eval shellfilter::chan { #todo - something similar for multiple grep specs each with own -pre & -post .. store to dict? oo::class create tee_grep_to_var { variable o_datavar - variable o_lastxlines - variable o_trecord + variable o_lastxlines + variable o_trecord variable o_grepfor variable o_prelines variable o_postlines - variable o_postcountdown + variable o_postcountdown variable o_enc variable o_is_junction constructor {tf} { @@ -240,8 +241,8 @@ namespace eval shellfilter::chan { # return ? #} method write {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - set lastx $o_lastxlines + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set lastx $o_lastxlines lappend o_lastxlines $logdata if {$o_postcountdown > 0} { @@ -399,7 +400,7 @@ namespace eval shellfilter::chan { return "" } method read {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set logdata [tcl::encoding::convertfrom $o_enc $bytes] #::shellfilter::log::write $o_logsource $logdata puts -nonewline $o_localchan $logdata return $bytes @@ -415,14 +416,14 @@ namespace eval shellfilter::chan { set inputbytes $o_encbuf$bytes set o_encbuf "" set tail_offset 0 - while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} { + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { incr tail_offset } if {$tail_offset > 0} { - if {$tail_offset < [string length $inputbytes]} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { #stringdata from catch statement must be a valid result set t [expr {$tail_offset - 1}] - set o_encbuf [string range $inputbytes end-$t end] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] } else { set stringdata "" set o_encbuf $inputbytes @@ -432,7 +433,7 @@ namespace eval shellfilter::chan { #::shellfilter::log::write $o_logsource $logdata puts -nonewline $o_localchan $stringdata #return $bytes - return [string range $inputbytes 0 end-$tail_offset] + return [::tcl::string::range $inputbytes 0 end-$tail_offset] } #a tee is not a redirection - because data still flows along the main path method meta_is_redirection {} { @@ -441,9 +442,9 @@ namespace eval shellfilter::chan { } oo::class create tee_to_log { - variable o_tid + variable o_tid variable o_logsource - variable o_trecord + variable o_trecord variable o_enc variable o_encbuf variable o_is_junction @@ -475,7 +476,7 @@ namespace eval shellfilter::chan { # post any events } method read {ch bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set logdata [tcl::encoding::convertfrom $o_enc $bytes] ::shellfilter::log::write $o_logsource $logdata return $bytes } @@ -486,27 +487,27 @@ namespace eval shellfilter::chan { return $o_encbuf } method write {ch bytes} { - #set logdata [tcl::encoding::convertfrom $o_enc $bytes] + #set logdata [tcl::encoding::convertfrom $o_enc $bytes] set inputbytes $o_encbuf$bytes set o_encbuf "" set tail_offset 0 - while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} { + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { incr tail_offset } if {$tail_offset > 0} { - if {$tail_offset < [string length $inputbytes]} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { #stringdata from catch statement must be a valid result set t [expr {$tail_offset - 1}] - set o_encbuf [string range $inputbytes end-$t end] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] } else { set stringdata "" set o_encbuf $inputbytes return "" } } - ::shellfilter::log::write $o_logsource $logdata - #return $bytes - return [string range $inputbytes 0 end-$tail_offset] + set bytes [::tcl::string::range $inputbytes 0 end-$tail_offset] + ::shellfilter::log::write $o_logsource $stringdata + return $bytes } method meta_is_redirection {} { return $o_is_junction @@ -546,18 +547,18 @@ namespace eval shellfilter::chan { # return ? #} method write {transform_handle bytes} { - #set logdata [encoding convertfrom $o_enc $bytes] + #set logdata [encoding convertfrom $o_enc $bytes] set inputbytes $o_encbuf$bytes set o_encbuf "" set tail_offset 0 - while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} { + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { incr tail_offset } if {$tail_offset > 0} { - if {$tail_offset < [string length $inputbytes]} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { #stringdata from catch statement must be a valid result set t [expr {$tail_offset - 1}] - set o_encbuf [string range $inputbytes end-$t end] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] } else { set stringdata "" set o_encbuf $inputbytes @@ -574,7 +575,7 @@ namespace eval shellfilter::chan { } } - #review - we should probably provide a more narrow filter than only strips color - and one that strips most(?) + #review - we should probably provide a more narrow filter than only strips color - and one that strips most(?) # - but does it ever really make sense to strip things like "esc(0" and "esc(B" which flip to the G0 G1 characters? (once stripped - things like box-lines become ordinary letters - unlikely to be desired?) #punk::ansi::ansistrip converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion #assumes line-buffering. a more advanced filter required if ansicodes can arrive split across separate read or write operations! @@ -586,10 +587,10 @@ namespace eval shellfilter::chan { constructor {tf} { package require punk::ansi set o_trecord $tf - set o_enc [dict get $tf -encoding] + set o_enc [::tcl::dict::get $tf -encoding] set o_encbuf "" - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] + if {[::tcl::dict::exists $tf -junction]} { + set o_is_junction [::tcl::dict::get $tf -junction] } else { set o_is_junction 0 } @@ -609,7 +610,7 @@ namespace eval shellfilter::chan { return "" } method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] + set instring [encoding convertfrom $o_enc $bytes] set outstring [punk::ansi::ansistrip $instring] return [encoding convertto $o_enc $outstring] } @@ -618,7 +619,7 @@ namespace eval shellfilter::chan { } #method write {transform_handle bytes} { # #broken due to occasional unexpected byte sequence - # set instring [encoding convertfrom $o_enc $bytes] + # set instring [encoding convertfrom $o_enc $bytes] # set outstring [punk::ansi::ansistrip $instring] # return [encoding convertto $o_enc $outstring] #} @@ -629,14 +630,14 @@ namespace eval shellfilter::chan { set inputbytes $o_encbuf$bytes set o_encbuf "" set tail_offset 0 - while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} { + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { incr tail_offset } if {$tail_offset > 0} { - if {$tail_offset < [string length $inputbytes]} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { #stringdata from catch statement must be a valid result set t [expr {$tail_offset - 1}] - set o_encbuf [string range $inputbytes end-$t end] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] } else { set stringdata "" set o_encbuf $inputbytes @@ -654,7 +655,7 @@ namespace eval shellfilter::chan { #a test oo::class create reconvert { - variable o_trecord + variable o_trecord variable o_enc constructor {tf} { set o_trecord $tf @@ -669,14 +670,14 @@ namespace eval shellfilter::chan { method watch {transform_handle events} { } method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] + set instring [encoding convertfrom $o_enc $bytes] set outstring $instring return [encoding convertto $o_enc $outstring] } method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] + set instring [encoding convertfrom $o_enc $bytes] set outstring $instring @@ -689,7 +690,7 @@ namespace eval shellfilter::chan { } } - + #this isn't a particularly nice thing to do to a stream - especially if someone isn't expecting ansi codes sprinkled through it. #It can be useful for test/debugging #Due to chunking at random breaks - we have to check if an ansi code in the underlying stream has been split - otherwise our wrapping will break the existing ansi @@ -809,10 +810,10 @@ namespace eval shellfilter::chan { 7GFX { switch -- [tcl::string::index $code 2] { "0" { - set o_gx_state on + set o_gx_state on } "B" { - set o_gx_state off + set o_gx_state off } } } @@ -862,7 +863,7 @@ namespace eval shellfilter::chan { } else { #REVIEW - this holding a buffer without emitting as we go is ugly. # - we may do better to detect and retain the opener, then use that opener to avoid false splits within the sequence. - # - we'd then need to detect the appropriate close to restart splitting and codestacking + # - we'd then need to detect the appropriate close to restart splitting and codestacking # - we may still need to retain and append the data to the opener (in some cases?) - which is a slight memory issue - but at least we would emit everything immediately. @@ -892,7 +893,7 @@ namespace eval shellfilter::chan { set o_buffered "" } } else { - set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code + set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code #most opening sequences are 1,2 or 3 chars - review? set open_sequence_detected [punk::ansi::ta::detect_open $buf] if {$possible_code_len > 10 && !$open_sequence_detected} { @@ -993,7 +994,7 @@ namespace eval shellfilter::chan { puts stdout "" set emit [tcl::encoding::convertto $o_enc $o_buffered] set o_buffered "" - return $emit + return $emit } method flush {transform_handle} { #puts stdout "" @@ -1063,7 +1064,7 @@ namespace eval shellfilter::chan { return $o_is_junction } } - #todo - something + #todo - something oo::class create rebuffer { variable o_trecord variable o_enc @@ -1080,14 +1081,14 @@ namespace eval shellfilter::chan { method watch {transform_handle events} { } method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] + set instring [encoding convertfrom $o_enc $bytes] set outstring $instring return [encoding convertto $o_enc $outstring] } method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] + set instring [encoding convertfrom $o_enc $bytes] #set outstring [string map [list \n ] $instring] set outstring $instring @@ -1102,9 +1103,9 @@ namespace eval shellfilter::chan { } } - #has slight buffering/withholding of lone training cr - we can't be sure that a cr at end of chunk is part of \r\n sequence + #has slight buffering/withholding of lone training cr - we can't be sure that a cr at end of chunk is part of \r\n sequence oo::class create tounix { - variable o_trecord + variable o_trecord variable o_enc variable o_last_char_was_cr variable o_is_junction @@ -1129,14 +1130,14 @@ namespace eval shellfilter::chan { } #don't use read method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] + set instring [encoding convertfrom $o_enc $bytes] set outstring $instring return [encoding convertto $o_enc $outstring] } method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] + set instring [encoding convertfrom $o_enc $bytes] #set outstring [string map [list \n ] $instring] if {$o_last_char_was_cr} { @@ -1144,7 +1145,7 @@ namespace eval shellfilter::chan { } set outstring [string map {\r\n \n} $instring] - set lastchar [string range $outstring end end] + set lastchar [string range $outstring end end] if {$lastchar eq "\r"} { set o_last_char_was_cr 1 set outstring [string range $outstring 0 end-1] @@ -1165,7 +1166,7 @@ namespace eval shellfilter::chan { } #write to handle case where line-endings already \r\n too oo::class create towindows { - variable o_trecord + variable o_trecord variable o_enc variable o_last_char_was_cr variable o_is_junction @@ -1190,14 +1191,14 @@ namespace eval shellfilter::chan { } #don't use read method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] + set instring [encoding convertfrom $o_enc $bytes] set outstring $instring return [encoding convertto $o_enc $outstring] } method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] + set instring [encoding convertfrom $o_enc $bytes] #set outstring [string map [list \n ] $instring] if {$o_last_char_was_cr} { @@ -1208,7 +1209,7 @@ namespace eval shellfilter::chan { set outstring [string map {\n \r\n} $outstring] set outstring [string map {\uFFFF \r\n} $outstring] - set lastchar [string range $outstring end end] + set lastchar [string range $outstring end end] if {$lastchar eq "\r"} { set o_last_char_was_cr 1 set outstring [string range $outstring 0 end-1] @@ -1224,7 +1225,7 @@ namespace eval shellfilter::chan { } oo::define towindows { method meta_is_redirection {} { - return $o_is_junction + return $o_is_junction } } @@ -1234,17 +1235,17 @@ namespace eval shellfilter::chan { # ---------------------------------------------------------------------------- #review float/sink metaphor. #perhaps something with the concept of upstream and downstream? -#need concepts for push towards data, sit in middle where placed, and lag at tail of data stream. +#need concepts for push towards data, sit in middle where placed, and lag at tail of data stream. ## upstream for stdin is at the bottom of the stack and for stdout is the top of the stack. #upstream,neutral-upstream,downstream,downstream-aside,downstream-replace (default neutral-upstream - require action 'stack' to use standard channel stacking concept and ignore other actions) #This is is a bit different from the float/sink metaphor which refers to the channel stacking order as opposed to the data-flow direction. -#The idea would be that whether input or output +#The idea would be that whether input or output # upstream additions go to the side closest to the datasource -# downstream additions go furthest from the datasource +# downstream additions go furthest from the datasource # - all new additions go ahead of any diversions as the most upstream diversion is the current end of the stream in a way. -# - this needs review regarding subsequent removal of the diversion and whether filters re-order in response.. -# or if downstream & neutral additions are reclassified upon insertion if they land among existing upstreams(?) -# neutral-upstream goes to the datasource side of the neutral-upstream list. +# - this needs review regarding subsequent removal of the diversion and whether filters re-order in response.. +# or if downstream & neutral additions are reclassified upon insertion if they land among existing upstreams(?) +# neutral-upstream goes to the datasource side of the neutral-upstream list. # No 'neutral' option provided so that we avoid the need to think forwards or backwards when adding stdin vs stdout shellfilter does the necessary pop/push reordering. # No 'neutral-downstream' to reduce complexity. # downstream-replace & downstream-aside head downstream to the first diversion they encounter. ie these actions are no longer referring to the stack direction but only the dataflow direction. @@ -1268,7 +1269,7 @@ namespace eval shellfilter::chan { # # ## note - whether stack is for input or output we maintain it in the same direction - which is in sync with the tcl chan pop chan push concept. -## +## namespace eval shellfilter::stack { namespace export {[a-z]*} namespace ensemble create @@ -1287,7 +1288,7 @@ namespace eval shellfilter::stack { } proc item_tophandle {pipename} { variable pipelines - set handle "" + set handle "" if {[dict exists $pipelines $pipename stack]} { set stack [dict get $pipelines $pipename stack] set topstack [lindex $stack end] ;#last item in stack is top (for output channels anyway) review comment. input chans? @@ -1320,7 +1321,7 @@ namespace eval shellfilter::stack { } set stack [dict get $pipelines $k stack] if {![llength $stack]} { - set stackinfo "" + set stackinfo "" } else { set tbl_inner [textblock::class::table new] $tbl_inner configure -show_edge 0 @@ -1409,7 +1410,7 @@ namespace eval shellfilter::stack { } return $tableprefix$table } - #used for output channels - we usually want to sink redirections below the floaters and down to topmost existing redir + #used for output channels - we usually want to sink redirections below the floaters and down to topmost existing redir proc _get_stack_floaters {stack} { set floaters [list] foreach t [lreverse $stack] { @@ -1460,9 +1461,9 @@ namespace eval shellfilter::stack { } - #for input-channels ? + #for input-channels ? proc _get_stack_bottom_redirection {stack} { - set i 0 + set i 0 foreach t $stack { set obj [dict get $t -obj] if {[$obj meta_is_redirection]} { @@ -1497,7 +1498,7 @@ namespace eval shellfilter::stack { proc delete {pipename {wait 0}} { variable pipelines set pipeinfo [dict get $pipelines $pipename] - set deviceinfo [dict get $pipeinfo device] + set deviceinfo [dict get $pipeinfo device] set localchan [dict get $deviceinfo localchan] unwind $pipename @@ -1512,7 +1513,7 @@ namespace eval shellfilter::stack { #Memchan closes without error - tcl::chan::fifo2 raises something like 'can not find channel named "rc977"' - REVIEW. why? catch {chan close $localchan} } - #review - proc name clarity is questionable. remove_stackitem? + #review - proc name clarity is questionable. remove_stackitem? proc remove {pipename remove_id} { variable pipelines if {![dict exists $pipelines $pipename]} { @@ -1534,7 +1535,7 @@ namespace eval shellfilter::stack { if {[llength [dict get $t -aside]]} { set a [dict get $t -aside] if {[dict get $a -id] eq $remove_id} { - set asideposn $posn + set asideposn $posn break } } @@ -1545,7 +1546,7 @@ namespace eval shellfilter::stack { #id wasn't found directly in stack, but in an -aside. we don't need to pop anything - just clear this aside record set container [lindex $stack $asideposn] dict set container -aside {} - lset stack $asideposn $container + lset stack $asideposn $container dict set pipelines $pipename stack $stack } else { if {$idposn < 0} { @@ -1553,7 +1554,7 @@ namespace eval shellfilter::stack { puts stderr "|WARNING>shellfilter::stack::remove $pipename id '$remove_id' not found" return 0 } - set removed_item [lindex $stack $idposn] + set removed_item [lindex $stack $idposn] #include idposn in poplist set poplist [lrange $stack $idposn end] @@ -1605,7 +1606,7 @@ namespace eval shellfilter::stack { set transformname [dict get $transformrecord -transform] set transformsettings [dict get $transformrecord -settings] set obj [$transformname new $transformrecord] - set h [chan push $localchan $obj] + set h [chan push $localchan $obj] dict set transformrecord -handle $h dict set transformrecord -obj $obj dict set transformrecord -note "insert_transform" @@ -1625,14 +1626,14 @@ namespace eval shellfilter::stack { return $stack } - #fifo2 + #fifo2 proc new {pipename args} { variable pipelines if {($pipename in [dict keys $pipelines]) || ($pipename in [chan names])} { error "shellfilter::stack::new error: pipename '$pipename' already exists" } - set opts [dict merge {-settings {}} $args] + set opts [dict merge {-settings {}} $args] set defaultsettings [dict create -raw 1 -buffering line -direction out] set targetsettings [dict merge $defaultsettings [dict get $opts -settings]] @@ -1687,7 +1688,7 @@ namespace eval shellfilter::stack { set deviceinfo [dict get $pipelines $pipename device] } - set id [get_next_counter $pipename] + set id [get_next_counter $pipename] set stack [dict get $pipelines $pipename stack] set localchan [dict get $deviceinfo localchan] @@ -1752,7 +1753,7 @@ namespace eval shellfilter::stack { set transformname [dict get $transform_record -transform] set transform_settings [dict get $transform_record -settings] set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] + set h [chan push $localchan $obj] dict set transform_record -handle $h dict set transform_record -obj $obj dict set transform_record -note "insert_transform-with-aside" @@ -1832,8 +1833,8 @@ namespace eval shellfilter { set action [dict get $args -action] } else { # action "sink" is a somewhat reasonable default for an output redirection transform - # but it can make it harder to configure a plain ordered stack if the user is not expecting it, so we'll default to stack - # also.. for stdin transform sink makes less sense.. + # but it can make it harder to configure a plain ordered stack if the user is not expecting it, so we'll default to stack + # also.. for stdin transform sink makes less sense.. #todo - default "stack" instead of empty string set action "" } @@ -1865,9 +1866,9 @@ namespace eval shellfilter { set tag [dict get $settings -tag] if {$tag ne $tagprefix} { - error "shellfilter::redir_output_to_log -tag value must match supplied tagprefix:'$tagprefix'. Omit -tag, or make it the same. It will automatically be suffixed with stderr and stdout. Use redir_channel_to_log if you want to separately configure each channel" + error "shellfilter::redir_output_to_log -tag value must match supplied tagprefix:'$tagprefix'. Omit -tag, or make it the same. It will automatically be suffixed with stderr and stdout. Use redir_channel_to_log if you want to separately configure each channel" } - lappend sources ${tagprefix}stdout ${tagprefix}stderr + lappend sources ${tagprefix}stdout ${tagprefix}stderr set stdoutsettings $settings dict set stdoutsettings -tag ${tagprefix}stdout @@ -1878,7 +1879,7 @@ namespace eval shellfilter { set iderr [redir_channel_to_log stderr -action [dict get $opts -action] -settings $stderrsettings] return [list $idout $iderr] - } + } #eg try: set v [list #a b c] #vs set v {#a b c} @@ -1888,8 +1889,8 @@ namespace eval shellfilter { string equal $l [list {*}$l] } - #return a dict keyed on numerical list index showing info about each element - # - particularly + #return a dict keyed on numerical list index showing info about each element + # - particularly # 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list # 'head_tail_chars' to show current first and last character (in case it's wrapped e.g in double or single quotes or an existing set of braces) proc list_element_info {inputlist} { @@ -2017,11 +2018,11 @@ namespace eval shellfilter { #parse bracketed expression (e.g produced by vim "shellxquote=(" ) into a tcl (nested) list - #e.g {(^c:/my spacey/path^ >^somewhere^)} - #e.g {(blah (etc))}" - #Result is always a list - even if only one toplevel set of brackets - so it may need [lindex $result 0] if input is the usual case of {( ...)} + #e.g {(^c:/my spacey/path^ >^somewhere^)} + #e.g {(blah (etc))}" + #Result is always a list - even if only one toplevel set of brackets - so it may need [lindex $result 0] if input is the usual case of {( ...)} # - because it also supports the perhaps less likely case of: {( ...) unbraced (...)} etc - # Note that + # Note that #maintenance warning - duplication in branches for bracketed vs unbracketed! proc parse_cmd_brackets {str} { #wordwrappers currently best suited to non-bracket entities - no bracket matching within - anything goes until end-token reached. @@ -2034,13 +2035,13 @@ namespace eval shellfilter { "\{" [list "\{" "\}" "\}"]\ {[} [list {[} {]} {]}]\ ] ;#dict mapping start_character to {replacehead replacetail expectedtail} - set shell_specials [list "|" "|&" "<" "<@" "<<" ">" "2>" ">&" ">>" "2>>" ">>&" ">@" "2>@" "2>@1" ">&@" "&" "&&" ] ;#words/chars that may precede an opening bracket but don't merge with the bracket to form a word. + set shell_specials [list "|" "|&" "<" "<@" "<<" ">" "2>" ">&" ">>" "2>>" ">>&" ">@" "2>@" "2>@1" ">&@" "&" "&&" ] ;#words/chars that may precede an opening bracket but don't merge with the bracket to form a word. #puts "pb:$str" set in_bracket 0 set in_word 0 set word "" set result {} - set word_bdepth 0 + set word_bdepth 0 set word_bstack [list] set wordwrap "" ;#only one active at a time set bracketed_elements [dict create] @@ -2066,7 +2067,7 @@ namespace eval shellfilter { #can potentially close off a word - or start a new one if word-so-far is a shell-special if {$word in $shell_specials} { if {$char eq ")"} { - dict lappend bracketed_elements $in_bracket $word + dict lappend bracketed_elements $in_bracket $word set subresult [dict get $bracketed_elements $in_bracket] dict set bracketed_elements $in_bracket [list] incr in_bracket -1 @@ -2078,11 +2079,11 @@ namespace eval shellfilter { set word "" set in_word 0 } elseif {[regexp {[\s]} $char]} { - dict lappend bracketed_elements $in_bracket $word + dict lappend bracketed_elements $in_bracket $word set word "" set in_word 0 - } elseif {$char eq "("} { - dict lappend bracketed_elements $in_bracket $word + } elseif {$char eq "("} { + dict lappend bracketed_elements $in_bracket $word set word "" set in_word 0 incr in_bracket @@ -2090,7 +2091,7 @@ namespace eval shellfilter { #at end of shell-specials is another point to look for word started by a wordwrapper char #- expect common case of things like >^/my/path^ if {$char in [dict keys $wordwrappers]} { - dict lappend bracketed_elements $in_bracket $word + dict lappend bracketed_elements $in_bracket $word set word "" set in_word 1 ;#just for explicitness.. we're straight into the next word. set wordwrap $char @@ -2101,7 +2102,7 @@ namespace eval shellfilter { } } } else { - + if {$char eq ")"} { dict lappend bracketed_elements $in_bracket $word set subresult [dict get $bracketed_elements $in_bracket] @@ -2120,7 +2121,7 @@ namespace eval shellfilter { set in_word 0 } elseif {$char eq "("} { #ordinary word up-against and opening bracket - brackets are part of word. - incr word_bdepth + incr word_bdepth append word "(" } else { append word $char @@ -2132,12 +2133,12 @@ namespace eval shellfilter { "(" { incr word_bdepth lappend word_bstack $char - append word $char + append word $char } ")" { incr word_bdepth -1 set word_bstack [lrange $word_bstack 0 end-1] - append word $char + append word $char } default { #spaces and chars added to word as it's still in a bracketed section @@ -2147,10 +2148,10 @@ namespace eval shellfilter { } } } else { - + if {$char eq "("} { incr in_bracket - + } elseif {$char eq ")"} { set subresult [dict get $bracketed_elements $in_bracket] dict set bracketed_elements $in_bracket [list] @@ -2187,15 +2188,15 @@ namespace eval shellfilter { append word $char } } else { - + if {$word_bdepth == 0} { if {$word in $shell_specials} { if {[regexp {[\s]} $char]} { - lappend result $word + lappend result $word set word "" set in_word 0 - } elseif {$char eq "("} { - lappend result $word + } elseif {$char eq "("} { + lappend result $word set word "" set in_word 0 incr in_bracket @@ -2203,7 +2204,7 @@ namespace eval shellfilter { #at end of shell-specials is another point to look for word started by a wordwrapper char #- expect common case of things like >^/my/path^ if {$char in [dict keys $wordwrappers]} { - lappend result $word + lappend result $word set word "" set in_word 1 ;#just for explicitness.. we're straight into the next word. set wordwrap $char @@ -2213,7 +2214,7 @@ namespace eval shellfilter { append word $char } } - + } else { if {[regexp {[\s)]} $char]} { lappend result $word @@ -2291,7 +2292,7 @@ namespace eval shellfilter { } } - #proc dquote_if_not_bracketed/braced? + #proc dquote_if_not_bracketed/braced? #wrap in double quotes if not double-quoted proc dquote_if_not_dquoted {a} { @@ -2354,7 +2355,7 @@ namespace eval shellfilter { } - # run a command (or tcl script) with tees applied to stdout/stderr/stdin (or whatever channels are being used) + # run a command (or tcl script) with tees applied to stdout/stderr/stdin (or whatever channels are being used) # By the point run is called - any transforms should already be in place on the channels if they're needed. # The tees will be inline with none,some or all of those transforms depending on how the stack was configured # (upstream,downstream configured via -float,-sink etc) @@ -2371,7 +2372,7 @@ namespace eval shellfilter { ::shellfilter::log::write $runtag " commandlist:'$commandlist' listlen:$listlen strlen:[string length $commandlist]" #flush stdout - #flush stderr + #flush stderr #adding filters with sink-aside will temporarily disable the existing redirection #All stderr/stdout from the shellcommand will now tee to the underlying stderr/stdout as well as the configured syslog @@ -2415,14 +2416,14 @@ namespace eval shellfilter { #set indeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_in device] #set inpipechan [dict get $indeviceinfo localchan] - #NOTE:These transforms are not necessarily at the top of each stack! + #NOTE:These transforms are not necessarily at the top of each stack! #The float/sink mechanism, along with whether existing transforms are diversionary decides where they sit. set id_out [shellfilter::stack::add $outchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_out -pipechan $outpipechan]] set id_err [shellfilter::stack::add $errchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_err -pipechan $errpipechan]] # need to use os level channel handle for stdin - try named pipes (or even sockets) instead of fifo2 for this # If non os-level channel - the command can't be run with the redirection - # stderr/stdout can be run with non-os handles in the call - + # stderr/stdout can be run with non-os handles in the call - # but then it does introduce issues with terminal-detection and behaviour for stdout at least # # input is also a tee - we never want to change the source at this point - just log/process a side-channel of it. @@ -2436,7 +2437,7 @@ namespace eval shellfilter { #we need to catch errors - and ensure stack::remove calls occur. #An error can be raised if the command couldn't even launch, as opposed to a non-zero exitcode and stderr output from the command itself. # - if {!$is_script} { + if {!$is_script} { set experiment 0 if {$experiment} { try { @@ -2447,7 +2448,7 @@ namespace eval shellfilter { set exitinfo [list exitcode $exitcode] } } else { - if {[catch { + if {[catch { #run process with stdout/stderr/stdin or with configured channels #set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan $inpipechan {*}$opts] set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan stdin {*}$opts] @@ -2493,7 +2494,7 @@ namespace eval shellfilter { # opening a thread or writing to a log/syslog close to possible process exit is probably not a great idea. # we should ensure the thread already exists early on if we really need logging here. - # + # #set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}] #::shellfilter::log::write $tidytag " logtidyuptags '$tags'" @@ -2519,7 +2520,7 @@ namespace eval shellfilter { if {$s ni $tidied_sources} { lappend remaining_sources $s } - } + } #set sources [concat $remaining_sources $tidytag] set sources $remaining_sources @@ -2587,7 +2588,7 @@ namespace eval shellfilter { error "Unknown option(s)'$invalid_flags': must be one of '$valid_flags'" } #line buffering generally best for output channels.. keeps relative output order of stdout/stdin closer to source order - #there may be data where line buffering is inappropriate, so it's configurable per std channel + #there may be data where line buffering is inappropriate, so it's configurable per std channel #reading inputs with line buffering can result in extraneous newlines as we can't detect trailing data with no newline before eof. set defaults [dict create \ -outchan stdout \ @@ -2653,7 +2654,7 @@ namespace eval shellfilter { switch -- [string trim $lastitem] { {&} { set name [lindex $commandlist 0] - #background execution - stdout and stderr from child still comes here - but process is backgrounded + #background execution - stdout and stderr from child still comes here - but process is backgrounded #FIX! - this is broken for paths with backslashes for example #set pidlist [exec {*}[concat $name [lrange $commandlist 1 end]]] set pidlist [exec {*}$commandlist] @@ -2664,7 +2665,7 @@ namespace eval shellfilter { set commandlist [lrange $commandlist 0 end-1] } default { - # 2> filename + # 2> filename # 2>> filename # 2>@ openfileid set redir2test [string range $lastitem 0 1] @@ -2683,7 +2684,7 @@ namespace eval shellfilter { #The problem here - is that we can't always know what was intended on the commandline regarding quoting ::shellfilter::log::write $runtag "checking for redirections in $commandlist" - #sometimes we see a redirection without a following space e.g >C:/somewhere + #sometimes we see a redirection without a following space e.g >C:/somewhere #normalize switch -regexp -- $lastitem\ {^>[/[:alpha:]]+} { @@ -2692,7 +2693,7 @@ namespace eval shellfilter { {^>>[/[:alpha:]]+} { set lastitem ">> [string range $lastitem 2 end]" } - + #for a redirection, we assume either a 2-element list at tail of form {> {some path maybe with spaces}} #or that the tail redirection is not wrapped.. x y z > {some path maybe with spaces} @@ -2705,7 +2706,7 @@ namespace eval shellfilter { #don't use lassign or lrange on the element itself without checking first #we can treat the commandlist as a whole as a well formed list but not neccessarily each element within. - #lassign $lastitem redir redirtarget + #lassign $lastitem redir redirtarget #set commandlist [lrange $commandlist 0 end-1] # set itemchars [split $lastitem ""] @@ -2713,9 +2714,9 @@ namespace eval shellfilter { set lastchar [lindex $itemchars end] #NAIVE test for double quoted only! - #consider for example {"a" x="b"} + #consider for example {"a" x="b"} #testing first and last is not decisive - #We need to decide what level of drilling down is even appropriate here.. + #We need to decide what level of drilling down is even appropriate here.. #if something was double wrapped - it was perhaps deliberate so we don't interpret it as something(?) set head_tail_chars [list $firstchar $lastchar] set doublequoted [expr {[llength [lsearch -all $head_tail_chars "\""]] == 2}] @@ -2734,11 +2735,11 @@ namespace eval shellfilter { set redir [lindex $innerwords 0] ;#a *potential* redir - to be tested below set redirtarget [lrange $innerwords 1 end] ;#all the rest } elseif {$doublequoted} { - ::shellfilter::log::write $debugname "doublequoting at tail of command '$commandlist'" + ::shellfilter::log::write $debugname "doublequoting at tail of command '$commandlist'" set inner [string range $lastitem 1 end-1] set innerwords [regexp -inline -all {\S+} $inner] set redir [lindex $innerwords 0] - set redirtarget [lrange $innerwords 1 end] + set redirtarget [lrange $innerwords 1 end] } else { set itemwords [regexp -inline -all {\S+} $lastitem] # e.g > c:\test becomes > {c:\test} @@ -2747,7 +2748,7 @@ namespace eval shellfilter { set redirtarget [lrange $itemwords 1 end] } set commandlist [lrange $commandlist 0 end-1] - + } elseif {[lindex $commandlist end-1] in [list ">>" ">"]} { #unwrapped redirection #we should be able to use list operations like lindex and lrange here as the command itself is hopefully still a well formed list @@ -2755,7 +2756,7 @@ namespace eval shellfilter { set redirtarget [lindex $commandlist end] set commandlist [lrange $commandlist 0 end-2] } else { - #no redirection + #no redirection set redir "" set redirtarget "" #no change to command list @@ -2791,7 +2792,7 @@ namespace eval shellfilter { } } default { - ::shellfilter::log::write $runtag "No redir found!!" + ::shellfilter::log::write $runtag "No redir found!!" } } @@ -2833,7 +2834,7 @@ namespace eval shellfilter { #-------------------------------------------- #Tested on windows. Works to stop in output when buffering is none, reading from channel with -translation auto - #cmd, pwsh, tcl + #cmd, pwsh, tcl #chan configure $outchan -translation lf #chan configure $errchan -translation lf #-------------------------------------------- @@ -2847,16 +2848,16 @@ namespace eval shellfilter { #todo - handle custom redirection of stderr to a file? if {[string length $custom_stderr]} { #::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist $custom_stderr] a+" - #set rdout [open |[concat $commandlist $custom_stderr] a+] + #set rdout [open |[concat $commandlist $custom_stderr] a+] ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list $custom_stderr <@$inchan]] [list RDONLY]" - set rdout [open |[concat $commandlist [list <@$inchan $custom_stderr]] [list RDONLY]] + set rdout [open |[concat $commandlist [list <@$inchan $custom_stderr]] [list RDONLY]] set rderr "bogus" ;#so we don't wait for it } else { ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]" #set rdout [open |[concat $commandlist [list 2>@$wrerr]] a+] #set rdout [open |[concat $commandlist [list 2>@$wrerr]] [list RDWR]] - # If we don't redirect stderr to our own tcl-based channel - then the transforms don't get applied. + # If we don't redirect stderr to our own tcl-based channel - then the transforms don't get applied. # This is the whole reason we need these file-event loops. # Ideally we need something like exec,open in tcl that interacts with transformed channels directly and emits as it runs, not only at termination # - and that at least appears like a terminal to the called command. @@ -2892,7 +2893,7 @@ namespace eval shellfilter { # puts stderr "pid [lindex $command_pids 0] is running" #} - + if {$debug} { ::shellfilter::log::write $debugname "pipeline pids: $command_pids" } @@ -2901,9 +2902,9 @@ namespace eval shellfilter { chan configure $rdout -buffering $outbuffering -blocking 0 - chan configure $rdout -translation $readprocesstranslation + chan configure $rdout -translation $readprocesstranslation - if {![string length $custom_stderr]} { + if {![string length $custom_stderr]} { chan event $rderr readable [list apply {{chan other wrerr outchan errchan waitfor errprefix errbuffering debug debugname pids} { if {$errbuffering eq "line"} { set countchunk [chan gets $chan chunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved @@ -2920,7 +2921,7 @@ namespace eval shellfilter { if {[string length $chunk]} { puts -nonewline $errchan $chunk } - } + } if {[chan eof $chan]} { flush $errchan ;#jmn #set subprocesses [tcl::process::list] @@ -2944,16 +2945,16 @@ namespace eval shellfilter { #todo - handle case where large amount of stdin coming in faster than rdout can handle #as is - arbitrary amount of memory could be used because we aren't using a filevent for rdout being writable - # - we're just pumping it in to the non-blocking rdout buffers + # - we're just pumping it in to the non-blocking rdout buffers # ie there is no backpressure and stdin will suck in as fast as possible. # for most commandlines this probably isn't too big a deal.. but it could be a problem for multi-GB disk images etc # # - + ## Note - detecting trailing missing nl before eof is basically the same here as when reading rdout from executable # - but there is a slight difference in that with rdout we get an extra blocked state just prior to the final read. # Not known if that is significant - ## with inchan configured -buffering line + ## with inchan configured -buffering line #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl -r cat #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof #instate b:0 eof:0 pend:-1 count:4 @@ -2986,48 +2987,48 @@ namespace eval shellfilter { set chunk [chan read $chan] if {[string length $chunk]} { puts -nonewline $wrchan $chunk - } + } } if {[chan eof $chan]} { puts stderr "|stdin_reader>eof [chan configure stdin]" chan event $chan readable {} - #chan close $chan + #chan close $chan chan close $wrchan write ;#half close #set $waitfor "stdin" } }} $inchan $rdout $inbuffering $waitvar] - + if {[string length $stdinhandler]} { chan configure stdin -buffering line -blocking 0 chan event stdin readable $stdinhandler } - } + } set actual_proc_out_buffering [chan configure $rdout -buffering] set actual_outchan_buffering [chan configure $outchan -buffering] #despite whatever is configured - we match our reading to how we need to output set read_proc_out_buffering $actual_outchan_buffering - + if {[string length $teefile]} { set logname "redir_[string map {: _} $winfile]_[tcl::clock::microseconds]" set tid [::shellfilter::log::open $logname {-syslog 127.0.0.1:514}] if {$teefile eq "write"} { - ::shellfilter::log::write $logname "opening '$winfile' for write" + ::shellfilter::log::write $logname "opening '$winfile' for write" set fd [open $winfile w] } else { - ::shellfilter::log::write $logname "opening '$winfile' for appending" + ::shellfilter::log::write $logname "opening '$winfile' for appending" set fd [open $winfile a] } - #chan configure $fd -translation lf + #chan configure $fd -translation lf chan configure $fd -translation $outtranslation - chan configure $fd -encoding utf-8 + chan configure $fd -encoding utf-8 - set tempvar_bytetotal [namespace current]::totalbytes[tcl::clock::microseconds] + set tempvar_bytetotal [namespace current]::totalbytes[tcl::clock::microseconds] set $tempvar_bytetotal 0 chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname writefile writefilefd copytempfile bytevar logtag} { - #review - if we write outprefix to normal stdout.. why not to redirected file? + #review - if we write outprefix to normal stdout.. why not to redirected file? #usefulness of outprefix is dubious upvar $bytevar totalbytes if {$read_proc_out_buffering eq "line"} { @@ -3057,7 +3058,7 @@ namespace eval shellfilter { if {[chan eof $chan]} { flush $writefilefd ;#jmn #set blocking so we can get exit code - chan configure $chan -blocking 1 + chan configure $chan -blocking 1 catch {::shellfilter::log::write $logtag "${outprefix} total bytes $totalbytes written to $writefile"} #puts $outchan "${outprefix} total bytes $totalbytes written to $writefile" catch {close $writefilefd} @@ -3086,7 +3087,7 @@ namespace eval shellfilter { } } }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $winfile $fd $copytempfile $tempvar_bytetotal $logname] - + } else { # This occurs when we have outbuffering set to 'line' - as the 'input' from rdout which comes from the executable is also configured to 'line' @@ -3136,19 +3137,19 @@ namespace eval shellfilter { #Note that reading from -buffering none and writing straight out gives no problem because we pass the newlines through as is - + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($rdout) 0 ;#a very specific case of readblocked prior to eof.. possibly not important - #this detection is disabled for now - but left for debugging in case it means something.. or changes + #this detection is disabled for now - but left for debugging in case it means something.. or changes chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname pids} { #set outchunk [chan read $chan] - + if {$read_proc_out_buffering eq "line"} { set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved #countchunk can be -1 before eof e.g when blocked #debugging output inline with data - don't leave enabled #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" if {$countchunk >= 0} { - if {![chan eof $chan]} { + if {![chan eof $chan]} { puts $outchan ${outprefix}$outchunk } else { puts -nonewline $outchan ${outprefix}$outchunk @@ -3171,7 +3172,7 @@ namespace eval shellfilter { set outchunk [chan read $chan] #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:[string length $outchunk]" if {[string length $outchunk]} { - #set stringrep [encoding convertfrom utf-8 $outchunk] + #set stringrep [encoding convertfrom utf-8 $outchunk] #set newbytes [encoding convertto utf-16 $stringrep] #puts -nonewline $outchan $newbytes puts -nonewline $outchan $outchunk @@ -3219,7 +3220,7 @@ namespace eval shellfilter { catch {chan close $wrerr} #if {$other ni [chan names]} { # set $waitfor stdout - #} + #} if {[catch {chan configure $other}]} { set $waitfor stdout } @@ -3343,5 +3344,5 @@ namespace eval shellfilter { package provide shellfilter [namespace eval shellfilter { variable version - set version 0.2 + set version 0.2.1 }] diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 18b9ba2e..7733bfa7 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -11069,8 +11069,8 @@ tcl::namespace::eval punk::args::argdocbase { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::args::package { variable PUNKARGS + # @dynamic not required? lappend PUNKARGS [list { - @dynamic @id -id "::punk::args::package::standard_about" @cmd -name "%pkg%::about" -help\ "About %pkg% diff --git a/src/modules/shellfilter-999999.0a1.0.tm b/src/modules/shellfilter-999999.0a1.0.tm new file mode 100644 index 00000000..c8fdfb23 --- /dev/null +++ b/src/modules/shellfilter-999999.0a1.0.tm @@ -0,0 +1,3348 @@ +#copyright 2023 Julian Marcel Noble +#license: BSD (revised 3-clause) +# +#Note shellfilter is currently only directly useful for unidirectional channels e.g stdin,stderr,stdout, or for example fifo2 where only one direction is being used. +#To generalize this to bidrectional channels would require shifting around read & write methods on transform objects in a very complicated manner. +#e.g each transform would probably be a generic transform container which holds sub-objects to which read & write are indirected. +#This is left as a future exercise...possibly it's best left as a concept for uni-directional channels anyway +# - as presumably the reads/writes from a bidirectional channel could be diverted off to unidirectional pipelines for processing with less work +# (and maybe even better speed/efficiency if the data volume is asymmetrical and there is significant processing on one direction) +# + + +tcl::namespace::eval shellfilter::log { + variable allow_adhoc_tags 1 + variable open_logs [tcl::dict::create] + variable is_enabled 0 + + proc disable {} { + variable is_enabled + set is_enabled 0 + proc ::shellfilter::log::open {tag settingsdict} {} + proc ::shellfilter::log::write {tag msg} {} + proc ::shellfilter::log::write_sync {tag msg} {} + proc ::shellfilter::log::close {tag} {} + } + + proc enable {} { + variable is_enabled + set is_enabled 1 + #'tag' is an identifier for the log source. + # each tag will use it's own thread to write to the configured log target + proc ::shellfilter::log::open {tag {settingsdict {}}} { + upvar ::shellfilter::sources sourcelist + if {![dict exists $settingsdict -tag]} { + tcl::dict::set settingsdict -tag $tag + } else { + #review + if {$tag ne [tcl::dict::get $settingsdict -tag]} { + error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" + } + } + if {$tag ni $sourcelist} { + lappend sourcelist $tag + } + + #note new_worker + set worker_tid [shellthread::manager::new_worker $tag $settingsdict] + #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" + return $worker_tid + } + proc ::shellfilter::log::write {tag msg} { + upvar ::shellfilter::sources sourcelist + variable allow_adhoc_tags + if {!$allow_adhoc_tags} { + if {$tag ni $sourcelist} { + error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag , and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags" + } + } + shellthread::manager::write_log $tag $msg + } + #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written + proc ::shellfilter::log::write_sync {tag msg} { + shellthread::manager::write_log $tag $msg -async 0 + } + proc ::shellfilter::log::close {tag} { + #shellthread::manager::close_worker $tag + shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed + } + + } + + #review + #configure whether we can call shellfilter::log::write without having called open first + proc require_open {{is_open_required {}}} { + variable allow_adhoc_tags + if {![string length $is_open_required]} { + return $allow_adhoc_tags + } else { + #why not use string is boolean? + set truevalues [list y yes true 1] + set falsevalues [list n no false 0] + if {[string tolower $is_open_required] in $truevalues} { + set allow_adhoc_tags 1 + } elseif {[string tolower $is_open_required] in $falsevalues} { + set allow_adhoc_tags 0 + } else { + error "shellfilter::log::require_open unrecognised value '$is_open_required' try one of $truevalues or $falsevalues" + } + } + } + if {[catch {package require shellthread}]} { + shellfilter::log::disable + } else { + shellfilter::log::enable + } + +} +namespace eval shellfilter::pipe { + #write channel for program. workerthread reads other end of fifo2 and writes data somewhere + proc open_out {tag_pipename {pipesettingsdict {}}} { + set defaultsettings {-buffering full} + set settingsdict [dict merge $defaultsettings $pipesettingsdict] + package require shellthread + #we are only using the fifo in a single direction to pipe to another thread + # - so whilst wchan and rchan could theoretically each be both read & write we're only using them for one operation each + if {![catch {package require Memchan}]} { + lassign [fifo2] wchan rchan + } else { + package require tcl::chan::fifo2 + lassign [tcl::chan::fifo2] wchan rchan + } + #default -translation for both types of fifo on windows is {auto crlf} + # -encoding is as per '[encoding system]' on the platform - e.g utf-8 (e.g windows when beta-utf8 enabled) + chan configure $wchan -buffering [dict get $settingsdict -buffering] ;# + #application end must not be binary for our filters to operate on it + + + #chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation binary ;#works reasonably.. + chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation lf + + set worker_tid [shellthread::manager::new_pipe_worker $tag_pipename $settingsdict] + #puts stderr "worker_tid: $worker_tid" + + #set_read_pipe does the thread::transfer of the rchan end. -buffering setting is maintained during thread transfer + shellthread::manager::set_pipe_read_from_client $tag_pipename $worker_tid $rchan + + set pipeinfo [list localchan $wchan remotechan $rchan workertid $worker_tid direction out] + return $pipeinfo + } + + #read channel for program. workerthread writes to other end of fifo2 from whereever it's reading (stdin, file?) + proc open_in {tag_pipename {settingsdict {} }} { + package require shellthread + package require tcl::chan::fifo2 + lassign [tcl::chan::fifo2] wchan rchan + set program_chan $rchan + set worker_chan $wchan + chan configure $worker_chan -buffering [dict get $settingsdict -buffering] + chan configure $program_chan -buffering [dict get $settingsdict -buffering] + + chan configure $program_chan -blocking 0 + chan configure $worker_chan -blocking 0 + set worker_tid [shellthread::manager::new_worker $tag_pipename $settingsdict] + + shellthread::manager::set_pipe_write_to_client $tag_pipename $worker_tid $worker_chan + + set pipeinfo [list localchan $program_chan remotechan $worker_chan workertid $worker_tid direction in] + puts stderr "|jn>pipe::open_in returning $pipeinfo" + puts stderr "program_chan: [chan conf $program_chan]" + return $pipeinfo + } + +} + + +namespace eval shellfilter::chan { + set testobj ::shellfilter::chan::var + if {$testobj ni [info commands $testobj]} { + + oo::class create var { + variable o_datavar + variable o_trecord + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + set varname [dict get $settingsdict -varname] + set o_datavar $varname + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 1 ;# as a var is diversionary - default it to be a jucntion + } + } + method initialize {ch mode} { + return [list initialize finalize write] + } + method finalize {ch} { + my destroy + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {ch count} { + # return ? + #} + method write {ch bytes} { + set stringdata [encoding convertfrom $o_enc $bytes] + append $o_datavar $stringdata + return "" + } + method meta_is_redirection {} { + return $o_is_junction + } + method meta_buffering_supported {} { + return [list line full none] + } + } + + #todo - something similar for multiple grep specs each with own -pre & -post .. store to dict? + oo::class create tee_grep_to_var { + variable o_datavar + variable o_lastxlines + variable o_trecord + variable o_grepfor + variable o_prelines + variable o_postlines + variable o_postcountdown + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_lastxlines [list] + set o_postcountdown 0 + set defaults [tcl::dict::create -pre 1 -post 1] + set settingsdict [tcl::dict::get $tf -settings] + set settings [tcl::dict::merge $defaults $settingsdict] + set o_datavar [tcl::dict::get $settings -varname] + set o_grepfor [tcl::dict::get $settings -grep] + set o_prelines [tcl::dict::get $settings -pre] + set o_postlines [tcl::dict::get $settings -post] + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize finalize write] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #method read {transform_handle count} { + # return ? + #} + method write {transform_handle bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set lastx $o_lastxlines + lappend o_lastxlines $logdata + + if {$o_postcountdown > 0} { + append $o_datavar $logdata + if {[regexp $o_grepfor $logdata]} { + #another match in postlines + set o_postcountdown $o_postlines + } else { + incr o_postcountdown -1 + } + } else { + if {[regexp $o_grepfor $logdata]} { + append $o_datavar [join $lastx] + append $o_datavar $logdata + set o_postcountdown $o_postlines + } + } + + if {[llength $o_lastxlines] > $o_prelines} { + set o_lastxlines [lrange $o_lastxlines 1 end] + } + return $bytes + } + method meta_is_redirection {} { + return $o_is_junction + } + method meta_buffering_supported {} { + return [list line] + } + } + + oo::class create tee_to_var { + variable o_datavars + variable o_trecord + variable o_enc + variable o_encbuf + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_encbuf "" + set settingsdict [tcl::dict::get $tf -settings] + set varname [tcl::dict::get $settingsdict -varname] + set o_datavars $varname + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {ch mode} { + return [list initialize finalize write flush clear] + } + method finalize {ch} { + my destroy + } + method clear {ch} { + return + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {ch count} { + # return ? + #} + #method flush {ch} { + # return "" + #} + method flush {transform_handle} { + #puts stdout "" + #review - just clear o_encbuf and emit nothing? + #we wouldn't have a value there if it was convertable from the channel encoding? + set clear $o_encbuf + set o_encbuf "" + return $o_encbuf + } + method write {ch bytes} { + #test with set x [string repeat " \U1f6c8" 2043] + #or + #test with set x [string repeat " \U1f6c8" 683] + #most windows terminals (at least) may emit two unrecognised chars "??" at the end + + #Our goal with the while loop here is to avoid encoding conversion errors + #the source of the bogus chars in terminals is unclear. + #Alacritty on windows doesn't seem to have the problem, but wezterm,cmd,windows terminal do. + + #set stringdata [tcl::encoding::convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [string length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [string range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + + foreach v $o_datavars { + append $v $stringdata + } + #return $bytes + return [string range $inputbytes 0 end-$tail_offset] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + oo::class create tee_to_pipe { + variable o_logsource + variable o_localchan + variable o_enc + variable o_encbuf + variable o_trecord + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_encbuf "" + set settingsdict [tcl::dict::get $tf -settings] + if {![dict exists $settingsdict -tag]} { + error "tee_to_pipe constructor settingsdict missing -tag" + } + set o_localchan [tcl::dict::get $settingsdict -pipechan] + set o_logsource [tcl::dict::get $settingsdict -tag] + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize read drain write flush clear finalize] + } + method finalize {transform_handle} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {transform_handle events} { + # must be present but we ignore it because we do not + # post any events + } + method clear {transform_handle} { + return + } + method drain {transform_handle} { + return "" + } + method read {transform_handle bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + #::shellfilter::log::write $o_logsource $logdata + puts -nonewline $o_localchan $logdata + return $bytes + } + method flush {transform_handle} { + #return "" + set clear $o_encbuf + set o_encbuf "" + return $o_encbuf + } + method write {transform_handle bytes} { + #set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + #::shellfilter::log::write $o_logsource $logdata + puts -nonewline $o_localchan $stringdata + #return $bytes + return [::tcl::string::range $inputbytes 0 end-$tail_offset] + } + #a tee is not a redirection - because data still flows along the main path + method meta_is_redirection {} { + return $o_is_junction + } + + } + oo::class create tee_to_log { + variable o_tid + variable o_logsource + variable o_trecord + variable o_enc + variable o_encbuf + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_encbuf "" + set settingsdict [tcl::dict::get $tf -settings] + if {![tcl::dict::exists $settingsdict -tag]} { + error "tee_to_log constructor settingsdict missing -tag" + } + set o_logsource [tcl::dict::get $settingsdict -tag] + set o_tid [::shellfilter::log::open $o_logsource $settingsdict] + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {ch mode} { + return [list initialize read write flush finalize] + } + method finalize {ch} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + method read {ch bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + ::shellfilter::log::write $o_logsource $logdata + return $bytes + } + method flush {transform_handle} { + #return "" + set clear $o_encbuf + set o_encbuf "" + return $o_encbuf + } + method write {ch bytes} { + #set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + set bytes [::tcl::string::range $inputbytes 0 end-$tail_offset] + ::shellfilter::log::write $o_logsource $stringdata + return $bytes + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + + oo::class create logonly { + variable o_tid + variable o_logsource + variable o_trecord + variable o_enc + variable o_encbuf + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set o_encbuf "" + set settingsdict [dict get $tf -settings] + if {![dict exists $settingsdict -tag]} { + error "logonly constructor settingsdict missing -tag" + } + set o_logsource [dict get $settingsdict -tag] + set o_tid [::shellfilter::log::open $o_logsource $settingsdict] + } + method initialize {transform_handle mode} { + return [list initialize finalize write] + } + method finalize {transform_handle} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {transform_handle events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {transform_handle count} { + # return ? + #} + method write {transform_handle bytes} { + #set logdata [encoding convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return + } + } + + #::shellfilter::log::write_sync $o_logsource $logdata + ::shellfilter::log::write $o_logsource $stringdata + return + } + method meta_is_redirection {} { + return 1 + } + } + + #review - we should probably provide a more narrow filter than only strips color - and one that strips most(?) + # - but does it ever really make sense to strip things like "esc(0" and "esc(B" which flip to the G0 G1 characters? (once stripped - things like box-lines become ordinary letters - unlikely to be desired?) + #punk::ansi::ansistrip converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion + #assumes line-buffering. a more advanced filter required if ansicodes can arrive split across separate read or write operations! + oo::class create ansistrip { + variable o_trecord + variable o_enc + variable o_encbuf + variable o_is_junction + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [::tcl::dict::get $tf -encoding] + set o_encbuf "" + if {[::tcl::dict::exists $tf -junction]} { + set o_is_junction [::tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize read write clear flush drain finalize] + } + method finalize {transform_handle} { + my destroy + } + method clear {transform_handle} { + return + } + method watch {transform_handle events} { + } + method drain {transform_handle} { + return "" + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + set outstring [punk::ansi::ansistrip $instring] + return [encoding convertto $o_enc $outstring] + } + method flush {transform_handle} { + return "" + } + #method write {transform_handle bytes} { + # #broken due to occasional unexpected byte sequence + # set instring [encoding convertfrom $o_enc $bytes] + # set outstring [punk::ansi::ansistrip $instring] + # return [encoding convertto $o_enc $outstring] + #} + method write {transform_handle bytes} { + #set instring [tcl::encoding::convertfrom $o_enc $bytes] ;naive approach will break due to unexpected byte sequence - occasionally + #bytes can break at arbitrary points making encoding conversions invalid. + + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + + set outstring [punk::ansi::ansistrip $stringdata] + return [tcl::encoding::convertto $o_enc $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + #a test + oo::class create reconvert { + variable o_trecord + variable o_enc + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + } + method initialize {transform_handle mode} { + return [list initialize read write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + } + oo::define reconvert { + method meta_is_redirection {} { + return 0 + } + } + + + #this isn't a particularly nice thing to do to a stream - especially if someone isn't expecting ansi codes sprinkled through it. + #It can be useful for test/debugging + #Due to chunking at random breaks - we have to check if an ansi code in the underlying stream has been split - otherwise our wrapping will break the existing ansi + # + set sixelstart_re {\x1bP([;0-9]*)q} ;#7-bit - todo 8bit + #todo kitty graphics \x1b_G... + #todo iterm graphics + + oo::class create ansiwrap { + variable o_trecord + variable o_enc + variable o_encbuf ;#buffering for partial encoding bytes + variable o_colour + variable o_do_colour + variable o_do_colourlist + variable o_do_normal + variable o_is_junction + variable o_codestack + variable o_gx_state ;#on/off alt graphics + variable o_buffered ;#buffering for partial ansi codes + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set settingsdict [tcl::dict::get $tf -settings] + if {[tcl::dict::exists $settingsdict -colour]} { + set o_colour [tcl::dict::get $settingsdict -colour] + #warning - we can't merge certain extended attributes such as undercurly into single SGR escape sequence + #while some terminals may handle these extended attributes even when merged - we need to cater for those that + #don't. Keeping them as a separate escape allows terminals that don't handle them to ignore just that code without + #affecting the interpretation of the other codes. + set o_do_colour [punk::ansi::a+ {*}$o_colour] + set o_do_colourlist [punk::ansi::ta::get_codes_single $o_do_colour] + set o_do_normal [punk::ansi::a] + } else { + set o_colour {} + set o_do_colour "" + set o_do_colourlist {} + set o_do_normal "" + } + set o_codestack [list] + set o_gx_state [expr {off}] + set o_encbuf "" + set o_buffered "" ;#hold back data that potentially contains partial ansi codes + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + + + #todo - track when in sixel,iterm,kitty graphics data - can be very large + method Trackcodes {chunk} { + #note - caller can use 2 resets in a single unit to temporarily reset to no sgr (override ansiwrap filter) + #e.g [a+ reset reset] (0;0m vs 0;m) + + #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]" + set buf $o_buffered$chunk + set emit "" + if {[string last \x1b $buf] >= 0} { + #detect will detect ansi SGR and gron groff and other codes + #REVIEW - ta::detect won't detect SOS without paired ST for things like PM + # ta::detectcode will - but then split_codes_single will treat unpaired SOS as text? + if {[punk::ansi::ta::detect $buf]} { + #split_codes_single regex faster than split_codes - but more resulting parts + #'single' refers to number of escapes - but can still contain e.g multiple SGR codes (or mode set operations etc) + set parts [punk::ansi::ta::split_codes_single $buf] + #process all pt/code pairs except for trailing pt + foreach {pt code} [lrange $parts 0 end-1] { + #puts "<==[ansistring VIEW -lf 1 $pt]==>" + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$pt + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$pt + } + } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # append emit $o_do_colour$pt$o_do_normal + # #append emit $pt + #} else { + # append emit $pt + #} + + set c1c2 [tcl::string::range $code 0 1] + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + ] $c1c2] 0 3] + switch -- $leadernorm { + 7CSI - 8CSI { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set o_codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set o_codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #todo - make caching is_sgr method + set dup_posns [lsearch -all -exact $o_codestack $code] + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $code + } else { + + } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set o_gx_state on + } + "B" { + set o_gx_state off + } + } + } + default { + #other ansi codes + } + } + append emit $code + } + + + set trailing_pt [lindex $parts end] + if {[string first \x1b $trailing_pt] >= 0} { + #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'" + #may not be plaintext after all + set o_buffered $trailing_pt + #puts stdout "=-=[ansistring VIEWCODES $o_buffered]" + } else { + #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a] + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$trailing_pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$trailing_pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$trailing_pt + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$trailing_pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$trailing_pt + } + } + #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { + # append emit $o_do_colour$trailing_pt$o_do_normal + #} else { + # append emit $trailing_pt + #} + #the previous o_buffered formed the data we emitted - nothing new to buffer because we emitted all parts including the trailing plaintext + set o_buffered "" + } + + + } else { + #REVIEW - this holding a buffer without emitting as we go is ugly. + # - we may do better to detect and retain the opener, then use that opener to avoid false splits within the sequence. + # - we'd then need to detect the appropriate close to restart splitting and codestacking + # - we may still need to retain and append the data to the opener (in some cases?) - which is a slight memory issue - but at least we would emit everything immediately. + + + #puts "-->esc but no detect" + #no complete ansi codes - but at least one esc is present + if {[string index $buf end] eq "\x1b" && [string first \x1b $buf] == [string length $buf]-1} { + #string index in first part of && clause to avoid some unneeded scans of whole string for this test + #we can't use 'string last' - as we need to know only esc is last char in buf + #puts ">>trailing-esc<<" + set o_buffered \x1b + set emit $o_do_colour[string range $buf 0 end-1]$o_do_normal + #set emit [string range $buf 0 end-1] + set buf "" + } else { + set emit_anyway 0 + #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer + if {[punk::ansi::ta::detect_st_open $buf]} { + #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms) + set st_partial_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code + #todo - configurable ST max - use 1k for now + if {$st_partial_len < 1001} { + append o_buffered $chunk + set emit "" + set buf "" + } else { + set emit_anyway 1 + set o_buffered "" + } + } else { + set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code + #most opening sequences are 1,2 or 3 chars - review? + set open_sequence_detected [punk::ansi::ta::detect_open $buf] + if {$possible_code_len > 10 && !$open_sequence_detected} { + set emit_anyway 1 + set o_buffered "" + } else { + #could be composite sequence with params - allow some reasonable max sequence length + #todo - configurable max sequence length + #len 40-50 quite possible for SGR sequence using coloured underlines etc, even without redundancies + # - allow some headroom for redundant codes when the caller didn't merge. + if {$possible_code_len < 101} { + append o_buffered $chunk + set buf "" + set emit "" + } else { + #allow a little more grace if we at least have an opening ansi sequence of any type.. + if {$open_sequence_detected && $possible_code_len < 151} { + append o_buffered $chunk + set buf "" + set emit "" + } else { + set emit_anyway 1 + set o_buffered "" + } + } + } + } + if {$emit_anyway} { + #assert: any time emit_anyway == 1 buf already contains all of previous o_buffered and o_buffered has been cleared. + + #looked ansi-like - but we've given enough length without detecting close.. + #treat as possible plain text with some esc or unrecognised ansi sequence + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # set emit $o_do_colour$buf$o_do_normal + #} else { + # set emit $buf + #} + } + } + } + } else { + #no esc + #puts stdout [a+ yellow]...[a] + #test! + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + set o_buffered "" + } + return [dict create emit $emit stacksize [llength $o_codestack]] + } + method initialize {transform_handle mode} { + #clear undesirable in terminal output channels (review) + return [list initialize write flush read drain finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method clear {transform_handle} { + #In the context of stderr/stdout - we probably don't want clear to run. + #Terminals might call it in the middle of a split ansi code - resulting in broken output. + #Leave clear of it the init call + puts stdout "" + set emit [tcl::encoding::convertto $o_enc $o_buffered] + set o_buffered "" + return $emit + } + method flush {transform_handle} { + #puts stdout "" + set inputbytes $o_buffered$o_encbuf + set emit [tcl::encoding::convertto $o_enc $inputbytes] + set o_buffered "" + set o_encbuf "" + return $emit + } + method write {transform_handle bytes} { + #set instring [tcl::encoding::convertfrom $o_enc $bytes] ;naive approach will break due to unexpected byte sequence - occasionally + #bytes can break at arbitrary points making encoding conversions invalid. + + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [string length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [string range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + set streaminfo [my Trackcodes $stringdata] + set emit [dict get $streaminfo emit] + + #review - wrapping already done in Trackcodes + #if {[dict get $streaminfo stacksize] == 0} { + # #no ansi on the stack - we can wrap + # #review + # set outstring "$o_do_colour$emit$o_do_normal" + #} else { + #} + #if {[llength $o_codestack]} { + # set outstring [punk::ansi::codetype::sgr_merge_singles $o_codestack]$emit + #} else { + # set outstring $emit + #} + #set outstring $emit + + #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<" + #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<" + return [tcl::encoding::convertto $o_enc $emit] + } + method Write_naive {transform_handle bytes} { + set instring [tcl::encoding::convertfrom $o_enc $bytes] + set outstring "$o_do_colour$instring$o_do_normal" + #set outstring ">>>$instring" + return [tcl::encoding::convertto $o_enc $outstring] + } + method drain {transform_handle} { + return "" + } + method read {transform_handle bytes} { + set instring [tcl::encoding::convertfrom $o_enc $bytes] + set outstring "$o_do_colour$instring$o_do_normal" + return [tcl::encoding::convertto $o_enc $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + #todo - something + oo::class create rebuffer { + variable o_trecord + variable o_enc + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + } + method initialize {transform_handle mode} { + return [list initialize read write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + #set outstring [string map [list \n ] $instring] + set outstring $instring + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define rebuffer { + method meta_is_redirection {} { + return 0 + } + } + + #has slight buffering/withholding of lone training cr - we can't be sure that a cr at end of chunk is part of \r\n sequence + oo::class create tounix { + variable o_trecord + variable o_enc + variable o_last_char_was_cr + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + set o_last_char_was_cr 0 + } + method initialize {transform_handle mode} { + return [list initialize write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #don't use read + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + #set outstring [string map [list \n ] $instring] + + if {$o_last_char_was_cr} { + set instring "\r$instring" + } + + set outstring [string map {\r\n \n} $instring] + set lastchar [string range $outstring end end] + if {$lastchar eq "\r"} { + set o_last_char_was_cr 1 + set outstring [string range $outstring 0 end-1] + } else { + set o_last_char_was_cr 0 + } + #review! can we detect eof here on the transform_handle? + #if eof, we don't want to strip a trailing \r + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define tounix { + method meta_is_redirection {} { + return $o_is_junction + } + } + #write to handle case where line-endings already \r\n too + oo::class create towindows { + variable o_trecord + variable o_enc + variable o_last_char_was_cr + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + set o_last_char_was_cr 0 + } + method initialize {transform_handle mode} { + return [list initialize write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #don't use read + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + #set outstring [string map [list \n ] $instring] + + if {$o_last_char_was_cr} { + set instring "\r$instring" + } + + set outstring [string map {\r\n \uFFFF} $instring] + set outstring [string map {\n \r\n} $outstring] + set outstring [string map {\uFFFF \r\n} $outstring] + + set lastchar [string range $outstring end end] + if {$lastchar eq "\r"} { + set o_last_char_was_cr 1 + set outstring [string range $outstring 0 end-1] + } else { + set o_last_char_was_cr 0 + } + #review! can we detect eof here on the transform_handle? + #if eof, we don't want to strip a trailing \r + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define towindows { + method meta_is_redirection {} { + return $o_is_junction + } + } + + } +} + +# ---------------------------------------------------------------------------- +#review float/sink metaphor. +#perhaps something with the concept of upstream and downstream? +#need concepts for push towards data, sit in middle where placed, and lag at tail of data stream. +## upstream for stdin is at the bottom of the stack and for stdout is the top of the stack. +#upstream,neutral-upstream,downstream,downstream-aside,downstream-replace (default neutral-upstream - require action 'stack' to use standard channel stacking concept and ignore other actions) +#This is is a bit different from the float/sink metaphor which refers to the channel stacking order as opposed to the data-flow direction. +#The idea would be that whether input or output +# upstream additions go to the side closest to the datasource +# downstream additions go furthest from the datasource +# - all new additions go ahead of any diversions as the most upstream diversion is the current end of the stream in a way. +# - this needs review regarding subsequent removal of the diversion and whether filters re-order in response.. +# or if downstream & neutral additions are reclassified upon insertion if they land among existing upstreams(?) +# neutral-upstream goes to the datasource side of the neutral-upstream list. +# No 'neutral' option provided so that we avoid the need to think forwards or backwards when adding stdin vs stdout shellfilter does the necessary pop/push reordering. +# No 'neutral-downstream' to reduce complexity. +# downstream-replace & downstream-aside head downstream to the first diversion they encounter. ie these actions are no longer referring to the stack direction but only the dataflow direction. +# +# ---------------------------------------------------------------------------- +# +# 'filters' are transforms that don't redirect +# - limited range of actions to reduce complexity. +# - any requirement not fulfilled by float,sink,sink-replace,sink-sideline should be done by multiple pops and pushes +# +#actions can float to top of filters or sink to bottom of filters +#when action is of type sink, it can optionally replace or sideline the first non-filter it encounters (highest redirection on the stack.. any lower are starved of the stream anyway) +# - sideline means to temporarily replace the item and keep a record, restoring if/when we are removed from the transform stack +# +##when action is of type float it can't replace or sideline anything. A float is added above any existing floats and they stay in the same order relative to each other, +#but non-floats added later will sit below all floats. +#(review - float/sink initially designed around output channels. For stdin the dataflow is reversed. implement float-aside etc?) +# +# +#action: float sink sink-replace,sink-sideline +# +# +## note - whether stack is for input or output we maintain it in the same direction - which is in sync with the tcl chan pop chan push concept. +## +namespace eval shellfilter::stack { + namespace export {[a-z]*} + namespace ensemble create + #todo - implement as oo ? + variable pipelines [list] + + proc items {} { + #review - stdin,stdout,stderr act as pre-existing pipelines, and we can't create a new one with these names - so they should probably be autoconfigured and listed.. + # - but in what contexts? only when we find them in [chan names]? + variable pipelines + return [dict keys $pipelines] + } + proc item {pipename} { + variable pipelines + return [dict get $pipelines $pipename] + } + proc item_tophandle {pipename} { + variable pipelines + set handle "" + if {[dict exists $pipelines $pipename stack]} { + set stack [dict get $pipelines $pipename stack] + set topstack [lindex $stack end] ;#last item in stack is top (for output channels anyway) review comment. input chans? + if {$topstack ne ""} { + if {[dict exists $topstack -handle]} { + set handle [dict get $topstack -handle] + } + } + } + return $handle + } + proc status {{pipename *} args} { + variable pipelines + set pipecount [dict size $pipelines] + set tabletitle "$pipecount pipelines active" + set t [textblock::class::table new $tabletitle] + $t add_column -headers [list channel-ident] + $t add_column -headers [list device-info localchan] + $t configure_column 1 -header_colspans {3} + $t add_column -headers [list "" remotechan] + $t add_column -headers [list "" tid] + $t add_column -headers [list stack-info] + foreach k [dict keys $pipelines $pipename] { + set lc [dict get $pipelines $k device localchan] + set rc [dict get $pipelines $k device remotechan] + if {[dict exists $k device workertid]} { + set tid [dict get $pipelines $k device workertid] + } else { + set tid "-" + } + set stack [dict get $pipelines $k stack] + if {![llength $stack]} { + set stackinfo "" + } else { + set tbl_inner [textblock::class::table new] + $tbl_inner configure -show_edge 0 + foreach rec $stack { + set handle [punk::lib::dict_getdef $rec -handle ""] + set id [punk::lib::dict_getdef $rec -id ""] + set transform [namespace tail [punk::lib::dict_getdef $rec -transform ""]] + set settings [punk::lib::dict_getdef $rec -settings ""] + $tbl_inner add_row [list $id $transform $handle $settings] + } + set stackinfo [$tbl_inner print] + $tbl_inner destroy + } + $t add_row [list $k $lc $rc $tid $stackinfo] + } + set result [$t print] + $t destroy + return $result + } + proc status1 {{pipename *} args} { + variable pipelines + + set pipecount [dict size $pipelines] + set tableprefix "$pipecount pipelines active\n" + foreach p [dict keys $pipelines] { + append tableprefix " " $p \n + } + package require overtype + #todo -verbose + set table "" + set ac1 [string repeat " " 15] + set ac2 [string repeat " " 42] + set ac3 [string repeat " " 70] + append table "[overtype::left $ac1 channel-ident] " + append table "[overtype::left $ac2 device-info] " + append table "[overtype::left $ac3 stack-info]" + append table \n + + + set bc1 [string repeat " " 5] ;#stack id + set bc2 [string repeat " " 25] ;#transform + set bc3 [string repeat " " 50] ;#settings + + foreach k [dict keys $pipelines $pipename] { + set lc [dict get $pipelines $k device localchan] + if {[dict exists $k device workertid]} { + set tid [dict get $pipelines $k device workertid] + } else { + set tid "" + } + + + set col1 [overtype::left $ac1 $k] + set col2 [overtype::left $ac2 "localchan: $lc tid:$tid"] + + set stack [dict get $pipelines $k stack] + if {![llength $stack]} { + set col3 $ac3 + } else { + set rec [lindex $stack 0] + set bcol1 [overtype::left $bc1 [dict get $rec -id]] + set bcol2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] + set bcol3 [overtype::left $bc3 [dict get $rec -settings]] + set stackrow "$bcol1 $bcol2 $bcol3" + set col3 [overtype::left $ac3 $stackrow] + } + + append table "$col1 $col2 $col3\n" + + + foreach rec [lrange $stack 1 end] { + set col1 $ac1 + set col2 $ac2 + if {[llength $rec]} { + set bc1 [overtype::left $bc1 [dict get $rec -id]] + set bc2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] + set bc3 [overtype::left $bc3 [dict get $rec -settings]] + set stackrow "$bc1 $bc2 $bc3" + set col3 [overtype::left $ac3 $stackrow] + } else { + set col3 $ac3 + } + append table "$col1 $col2 $col3\n" + } + + } + return $tableprefix$table + } + #used for output channels - we usually want to sink redirections below the floaters and down to topmost existing redir + proc _get_stack_floaters {stack} { + set floaters [list] + foreach t [lreverse $stack] { + switch -- [dict get $t -action] { + float { + lappend floaters $t + } + default { + break + } + } + } + return [lreverse $floaters] + } + + + + #for output-channel sinking + proc _get_stack_top_redirection {stack} { + set r 0 ;#reverse index + foreach t [lreverse $stack] { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index + return [list index $idx record $t] + } + incr r + } + #not found + return [list index -1 record {}] + } + #exclude float-locked, locked, sink-locked + proc _get_stack_top_redirection_replaceable {stack} { + set r 0 ;#reverse index + foreach t [lreverse $stack] { + set action [dict get $t -action] + if {![string match "*locked*" $action]} { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index + return [list index $idx record $t] + } + } + incr r + } + #not found + return [list index -1 record {}] + } + + + #for input-channels ? + proc _get_stack_bottom_redirection {stack} { + set i 0 + foreach t $stack { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + return [linst index $i record $t] + } + incr i + } + #not found + return [list index -1 record {}] + } + + + proc get_next_counter {pipename} { + variable pipelines + #use dictn incr ? + set counter [dict get $pipelines $pipename counter] + incr counter + dict set pipelines $pipename counter $counter + return $counter + } + + proc unwind {pipename} { + variable pipelines + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $pipelines $pipename device localchan] + foreach tf [lreverse $stack] { + chan pop $localchan + } + dict set pipelines $pipename [list] + } + #todo + proc delete {pipename {wait 0}} { + variable pipelines + set pipeinfo [dict get $pipelines $pipename] + set deviceinfo [dict get $pipeinfo device] + set localchan [dict get $deviceinfo localchan] + unwind $pipename + + #release associated thread + set tid [dict get $deviceinfo workertid] + if {$wait} { + thread::release -wait $tid + } else { + thread::release $tid + } + + #Memchan closes without error - tcl::chan::fifo2 raises something like 'can not find channel named "rc977"' - REVIEW. why? + catch {chan close $localchan} + } + #review - proc name clarity is questionable. remove_stackitem? + proc remove {pipename remove_id} { + variable pipelines + if {![dict exists $pipelines $pipename]} { + puts stderr "WARNING: shellfilter::stack::remove pipename '$pipename' not found in pipelines dict: '$pipelines' [info level -1]" + return + } + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $pipelines $pipename device localchan] + set posn 0 + set idposn -1 + set asideposn -1 + foreach t $stack { + set id [dict get $t -id] + if {$id eq $remove_id} { + set idposn $posn + break + } + #look into asides (only can be one for now) + if {[llength [dict get $t -aside]]} { + set a [dict get $t -aside] + if {[dict get $a -id] eq $remove_id} { + set asideposn $posn + break + } + } + incr posn + } + + if {$asideposn > 0} { + #id wasn't found directly in stack, but in an -aside. we don't need to pop anything - just clear this aside record + set container [lindex $stack $asideposn] + dict set container -aside {} + lset stack $asideposn $container + dict set pipelines $pipename stack $stack + } else { + if {$idposn < 0} { + ::shellfilter::log::write shellfilter "ERROR shellfilter::stack::remove $pipename id '$remove_id' not found" + puts stderr "|WARNING>shellfilter::stack::remove $pipename id '$remove_id' not found" + return 0 + } + set removed_item [lindex $stack $idposn] + + #include idposn in poplist + set poplist [lrange $stack $idposn end] + set stack [lreplace $stack $idposn end] + #pop all chans before adding anything back in! + foreach p $poplist { + chan pop $localchan + } + + if {[llength [dict get $removed_item -aside]]} { + set restore [dict get $removed_item -aside] + set t [dict get $restore -transform] + set tsettings [dict get $restore -settings] + set obj [$t new $restore] + set h [chan push $localchan $obj] + dict set restore -handle $h + dict set restore -obj $obj + lappend stack $restore + } + + #put popped back except for the first one, which we want to remove + foreach p [lrange $poplist 1 end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + dict set p -handle $h + dict set p -obj $obj + lappend stack $p + } + dict set pipelines $pipename stack $stack + } + #JMNJMN 2025 review! + #show_pipeline $pipename -note "after_remove $remove_id" + return 1 + } + + #pop a number of items of the top of the stack, add our transform record, and add back all (or the tail of poplist if pushstartindex > 0) + proc insert_transform {pipename stack transformrecord poplist {pushstartindex 0}} { + variable pipelines + set bottom_pop_posn [expr {[llength $stack] - [llength $poplist]}] + set poplist [lrange $stack $bottom_pop_posn end] + set stack [lreplace $stack $bottom_pop_posn end] + + set localchan [dict get $pipelines $pipename device localchan] + foreach p [lreverse $poplist] { + chan pop $localchan + } + set transformname [dict get $transformrecord -transform] + set transformsettings [dict get $transformrecord -settings] + set obj [$transformname new $transformrecord] + set h [chan push $localchan $obj] + dict set transformrecord -handle $h + dict set transformrecord -obj $obj + dict set transformrecord -note "insert_transform" + lappend stack $transformrecord + foreach p [lrange $poplist $pushstartindex end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + #retain previous -id - code that added it may have kept reference and not expecting it to change + dict set p -handle $h + dict set p -obj $obj + dict set p -note "re-added" + + lappend stack $p + } + return $stack + } + + #fifo2 + proc new {pipename args} { + variable pipelines + if {($pipename in [dict keys $pipelines]) || ($pipename in [chan names])} { + error "shellfilter::stack::new error: pipename '$pipename' already exists" + } + + set opts [dict merge {-settings {}} $args] + set defaultsettings [dict create -raw 1 -buffering line -direction out] + set targetsettings [dict merge $defaultsettings [dict get $opts -settings]] + + set direction [dict get $targetsettings -direction] + + #pipename is the source/facility-name ? + if {$direction eq "out"} { + set pipeinfo [shellfilter::pipe::open_out $pipename $targetsettings] + } else { + puts stderr "|jn> pipe::open_in $pipename $targetsettings" + set pipeinfo [shellfilter::pipe::open_in $pipename $targetsettings] + } + #open_out/open_in will configure buffering based on targetsettings + + set program_chan [dict get $pipeinfo localchan] + set worker_chan [dict get $pipeinfo remotechan] + set workertid [dict get $pipeinfo workertid] + + + set deviceinfo [dict create pipename $pipename localchan $program_chan remotechan $worker_chan workertid $workertid direction $direction] + dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] + + return $deviceinfo + } + #we 'add' rather than 'push' because transforms can float,sink and replace/sideline so they don't necessarily go to the top of the transform stack + proc add {pipename transformname args} { + variable pipelines + #chan names doesn't reflect available channels when transforms are in place + #e.g stdout may exist but show as something like file191f5b0dd80 + if {($pipename ni [dict keys $pipelines])} { + if {[catch {eof $pipename} is_eof]} { + error "shellfilter::stack::add no existing chan or pipename matching '$pipename' in channels:[chan names] or pipelines:$pipelines use stdin/stderr/stdout or shellfilter::stack::new " + } + } + set args [dict merge {-action "" -settings {}} $args] + set action [dict get $args -action] + set transformsettings [dict get $args -settings] + if {[string first "::" $transformname] < 0} { + set transformname ::shellfilter::chan::$transformname + } + if {![llength [info commands $transformname]]} { + error "shellfilter::stack::push unknown transform '$transformname'" + } + + + if {![dict exists $pipelines $pipename]} { + #pipename must be in chan names - existing device/chan + #record a -read and -write end even if the device is only being used as one or the other + set deviceinfo [dict create pipename $pipename localchan $pipename remotechan {}] + dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] + } else { + set deviceinfo [dict get $pipelines $pipename device] + } + + set id [get_next_counter $pipename] + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $deviceinfo localchan] + + #we redundantly store chan in each transform - makes debugging clearer + # -encoding similarly could be stored only at the pipeline level (or even queried directly each filter-read/write), + # but here it may help detect unexpected changes during lifetime of the stack and avoids the chance of callers incorrectly using the transform handle?) + # jn + set transform_record [list -id $id -chan $pipename -encoding [chan configure $localchan -encoding] -transform $transformname -aside {} {*}$args] + switch -glob -- $action { + float - float-locked { + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + lappend stack $transform_record + } + "" - locked { + set floaters [_get_stack_floaters $stack] + if {![llength $floaters]} { + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + lappend stack $transform_record + } else { + set poplist $floaters + set stack [insert_transform $pipename $stack $transform_record $poplist] + } + } + "sink*" { + set redirinfo [_get_stack_top_redirection $stack] + set idx_existing_redir [dict get $redirinfo index] + if {$idx_existing_redir == -1} { + #no existing redirection transform on the stack + #pop everything.. add this record as the first redirection on the stack + set poplist $stack + set stack [insert_transform $pipename $stack $transform_record $poplist] + } else { + switch -glob -- $action { + "sink-replace" { + #include that index in the poplist + set poplist [lrange $stack $idx_existing_redir end] + #pop all from idx_existing_redir to end, but put back 'lrange $poplist 1 end' + set stack [insert_transform $pipename $stack $transform_record $poplist 1] + } + "sink-aside*" { + set existing_redir_record [lindex $stack $idx_existing_redir] + if {[string match "*locked*" [dict get $existing_redir_record -action]]} { + set put_aside 0 + #we can't aside this one - sit above it instead. + set poplist [lrange $stack $idx_existing_redir+1 end] + set stack [lrange $stack 0 $idx_existing_redir] + } else { + set put_aside 1 + dict set transform_record -aside [lindex $stack $idx_existing_redir] + set poplist [lrange $stack $idx_existing_redir end] + set stack [lrange $stack 0 $idx_existing_redir-1] + } + foreach p $poplist { + chan pop $localchan + } + set transformname [dict get $transform_record -transform] + set transform_settings [dict get $transform_record -settings] + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + dict set transform_record -note "insert_transform-with-aside" + lappend stack $transform_record + #add back poplist *except* the one we transferred into -aside (if we were able) + foreach p [lrange $poplist $put_aside end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + #retain previous -id - code that added it may have kept reference and not expecting it to change + dict set p -handle $h + dict set p -obj $obj + dict set p -note "re-added-after-sink-aside" + lappend stack $p + } + } + default { + #plain "sink" + #we only sink to the topmost redirecting filter - which makes sense for an output channel + #For stdin.. this is more problematic as we're more likely to want to intercept the bottom most redirection. + #todo - review. Consider making default insert position for input channels to be at the source... and float/sink from there. + # - we don't currently know from the stack api if adding input vs output channel - so this needs work to make intuitive. + # consider splitting stack::add to stack::addinput stack::addoutput to split the different behaviour + set poplist [lrange $stack $idx_existing_redir+1 end] + set stack [insert_transform $pipename $stack $transform_record $poplist] + } + } + } + } + default { + error "shellfilter::stack::add unimplemented action '$action'" + } + } + + dict set pipelines $pipename stack $stack + #puts stdout "==" + #puts stdout "==>stack: $stack" + #puts stdout "==" + + #JMNJMN + #show_pipeline $pipename -note "after_add $transformname $args" + return $id + } + proc show_pipeline {pipename args} { + variable pipelines + set stack [dict get $pipelines $pipename stack] + set tag "SHELLFILTER::STACK" + #JMN - load from config + #::shellfilter::log::open $tag {-syslog 127.0.0.1:514} + if {[catch { + ::shellfilter::log::open $tag {-syslog ""} + } err]} { + #e.g safebase interp can't load required modules such as shellthread (or Thread) + puts stderr "shellfilter::show_pipeline cannot open log" + return + } + ::shellfilter::log::write $tag "transform stack for $pipename $args" + foreach tf $stack { + ::shellfilter::log::write $tag " $tf" + } + + } +} + + +namespace eval shellfilter { + variable sources [list] + variable stacks [dict create] + + proc ::shellfilter::redir_channel_to_log {chan args} { + variable sources + set default_logsettings [dict create \ + -tag redirected_$chan -syslog "" -file ""\ + ] + if {[dict exists $args -action]} { + set action [dict get $args -action] + } else { + # action "sink" is a somewhat reasonable default for an output redirection transform + # but it can make it harder to configure a plain ordered stack if the user is not expecting it, so we'll default to stack + # also.. for stdin transform sink makes less sense.. + #todo - default "stack" instead of empty string + set action "" + } + if {[dict exists $args -settings]} { + set logsettings [dict get $args -settings] + } else { + set logsettings {} + } + + set logsettings [dict merge $default_logsettings $logsettings] + set tag [dict get $logsettings -tag] + if {$tag ni $sources} { + lappend sources $tag + } + + set id [shellfilter::stack::add $chan logonly -action $action -settings $logsettings] + return $id + } + + proc ::shellfilter::redir_output_to_log {tagprefix args} { + variable sources + + set default_settings [list -tag ${tagprefix} -syslog "" -file ""] + + set opts [dict create -action "" -settings {}] + set opts [dict merge $opts $args] + set optsettings [dict get $opts -settings] + set settings [dict merge $default_settings $optsettings] + + set tag [dict get $settings -tag] + if {$tag ne $tagprefix} { + error "shellfilter::redir_output_to_log -tag value must match supplied tagprefix:'$tagprefix'. Omit -tag, or make it the same. It will automatically be suffixed with stderr and stdout. Use redir_channel_to_log if you want to separately configure each channel" + } + lappend sources ${tagprefix}stdout ${tagprefix}stderr + + set stdoutsettings $settings + dict set stdoutsettings -tag ${tagprefix}stdout + set stderrsettings $settings + dict set stderrsettings -tag ${tagprefix}stderr + + set idout [redir_channel_to_log stdout -action [dict get $opts -action] -settings $stdoutsettings] + set iderr [redir_channel_to_log stderr -action [dict get $opts -action] -settings $stderrsettings] + + return [list $idout $iderr] + } + + #eg try: set v [list #a b c] + #vs set v {#a b c} + proc list_is_canonical l { + #courtesy DKF via wiki https://wiki.tcl-lang.org/page/BNF+for+Tcl + if {[catch {llength $l}]} {return 0} + string equal $l [list {*}$l] + } + + #return a dict keyed on numerical list index showing info about each element + # - particularly + # 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list + # 'head_tail_chars' to show current first and last character (in case it's wrapped e.g in double or single quotes or an existing set of braces) + proc list_element_info {inputlist} { + set i 0 + set info [dict create] + set testlist [list] + foreach original_item $inputlist { + #--- + # avoid sharing internal rep with original items in the list (avoids shimmering of rep in original list for certain items such as paths) + unset -nocomplain item + append item $original_item {} + #--- + + set iteminfo [dict create] + set itemlen [string length $item] + lappend testlist $item + set tcl_len [string length $testlist] + set diff [expr {$tcl_len - $itemlen}] + if {$diff == 0} { + dict set iteminfo wouldbrace 0 + dict set iteminfo wouldescape 0 + } else { + #test for escaping vs bracing! + set testlistchars [split $testlist ""] + if {([lindex $testlistchars 0] eq "\{") && ([lindex $testlistchars end] eq "\}")} { + dict set iteminfo wouldbrace 1 + dict set iteminfo wouldescape 0 + } else { + dict set iteminfo wouldbrace 0 + dict set iteminfo wouldescape 1 + } + } + set testlist [list] + set charlist [split $item ""] + set char_a [lindex $charlist 0] + set char_b [lindex $charlist 1] + set char_ab ${char_a}${char_b} + set char_y [lindex $charlist end-1] + set char_z [lindex $charlist end] + set char_yz ${char_y}${char_z} + + if { ("{" in $charlist) || ("}" in $charlist) } { + dict set iteminfo has_braces 1 + set innerchars [lrange $charlist 1 end-1] + if {("{" in $innerchars) || ("}" in $innerchars)} { + dict set iteminfo has_inner_braces 1 + } else { + dict set iteminfo has_inner_braces 0 + } + } else { + dict set iteminfo has_braces 0 + dict set iteminfo has_inner_braces 0 + } + + #todo - brace/char counting to determine if actually 'wrapped' + #e.g we could have list element {((abc)} - which appears wrapped if only looking at first and last chars. + #also {(x) (y)} as a list member.. how to treat? + if {$itemlen <= 1} { + dict set iteminfo apparentwrap "not" + } else { + #todo - switch on $char_a$char_z + if {($char_a eq {"}) && ($char_z eq {"})} { + dict set iteminfo apparentwrap "doublequotes" + } elseif {($char_a eq "'") && ($char_z eq "'")} { + dict set iteminfo apparentwrap "singlequotes" + } elseif {($char_a eq "(") && ($char_z eq ")")} { + dict set iteminfo apparentwrap "brackets" + } elseif {($char_a eq "\{") && ($char_z eq "\}")} { + dict set iteminfo apparentwrap "braces" + } elseif {($char_a eq "^") && ($char_z eq "^")} { + dict set iteminfo apparentwrap "carets" + } elseif {($char_a eq "\[") && ($char_z eq "\]")} { + dict set iteminfo apparentwrap "squarebrackets" + } elseif {($char_a eq "`") && ($char_z eq "`")} { + dict set iteminfo apparentwrap "backquotes" + } elseif {($char_a eq "\n") && ($char_z eq "\n")} { + dict set iteminfo apparentwrap "lf-newline" + } elseif {($char_ab eq "\r\n") && ($char_yz eq "\r\n")} { + dict set iteminfo apparentwrap "crlf-newline" + } else { + dict set iteminfo apparentwrap "not-determined" + } + + } + dict set iteminfo wrapbalance "unknown" ;#a hint to caller that apparentwrap is only a guide. todo - possibly make wrapbalance indicate 0 for unbalanced.. and positive numbers for outer-count of wrappings. + #e.g {((x)} == 0 {((x))} == 1 {(x) (y (z))} == 2 + dict set iteminfo head_tail_chars [list $char_a $char_z] + set namemap [list \ + \r cr\ + \n lf\ + {"} doublequote\ + {'} singlequote\ + "`" backquote\ + "^" caret\ + \t tab\ + " " sp\ + "\[" lsquare\ + "\]" rsquare\ + "(" lbracket\ + ")" rbracket\ + "\{" lbrace\ + "\}" rbrace\ + \\ backslash\ + / forwardslash\ + ] + if {[string length $char_a]} { + set char_a_name [string map $namemap $char_a] + } else { + set char_a_name "emptystring" + } + if {[string length $char_z]} { + set char_z_name [string map $namemap $char_z] + } else { + set char_z_name "emptystring" + } + + dict set iteminfo head_tail_names [list $char_a_name $char_z_name] + dict set iteminfo len $itemlen + dict set iteminfo difflen $diff ;#2 for braces, 1 for quoting?, or 0. + dict set info $i $iteminfo + incr i + } + return $info + } + + + #parse bracketed expression (e.g produced by vim "shellxquote=(" ) into a tcl (nested) list + #e.g {(^c:/my spacey/path^ >^somewhere^)} + #e.g {(blah (etc))}" + #Result is always a list - even if only one toplevel set of brackets - so it may need [lindex $result 0] if input is the usual case of {( ...)} + # - because it also supports the perhaps less likely case of: {( ...) unbraced (...)} etc + # Note that + #maintenance warning - duplication in branches for bracketed vs unbracketed! + proc parse_cmd_brackets {str} { + #wordwrappers currently best suited to non-bracket entities - no bracket matching within - anything goes until end-token reached. + # - but.. they only take effect where a word can begin. so a[x y] may be split at the space unless it's within some other wraper e.g " a[x y]" will not break at the space + # todo - consider extending the in-word handling of word_bdepth which is currently only applied to () i.e aaa(x y) is supported but aaa[x y] is not as the space breaks the word up. + set wordwrappers [list \ + "\"" [list "\"" "\"" "\""]\ + {^} [list "\"" "\"" "^"]\ + "'" [list "'" "'" "'"]\ + "\{" [list "\{" "\}" "\}"]\ + {[} [list {[} {]} {]}]\ + ] ;#dict mapping start_character to {replacehead replacetail expectedtail} + set shell_specials [list "|" "|&" "<" "<@" "<<" ">" "2>" ">&" ">>" "2>>" ">>&" ">@" "2>@" "2>@1" ">&@" "&" "&&" ] ;#words/chars that may precede an opening bracket but don't merge with the bracket to form a word. + #puts "pb:$str" + set in_bracket 0 + set in_word 0 + set word "" + set result {} + set word_bdepth 0 + set word_bstack [list] + set wordwrap "" ;#only one active at a time + set bracketed_elements [dict create] + foreach char [split $str ""] { + #puts "c:$char bracketed:$bracketed_elements" + if {$in_bracket > 0} { + if {$in_word} { + if {[string length $wordwrap]} { + #anything goes until end-char + #todo - lookahead and only treat as closing if before a space or ")" ? + lassign [dict get $wordwrappers $wordwrap] _open closing endmark + if {$char eq $endmark} { + set wordwrap "" + append word $closing + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } else { + append word $char + } + } else { + if {$word_bdepth == 0} { + #can potentially close off a word - or start a new one if word-so-far is a shell-special + if {$word in $shell_specials} { + if {$char eq ")"} { + dict lappend bracketed_elements $in_bracket $word + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + set word "" + set in_word 0 + } elseif {[regexp {[\s]} $char]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + incr in_bracket + } else { + #at end of shell-specials is another point to look for word started by a wordwrapper char + #- expect common case of things like >^/my/path^ + if {$char in [dict keys $wordwrappers]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 1 ;#just for explicitness.. we're straight into the next word. + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + #something unusual.. keep going with word! + append word $char + } + } + } else { + + if {$char eq ")"} { + dict lappend bracketed_elements $in_bracket $word + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + set word "" + set in_word 0 + } elseif {[regexp {[\s]} $char]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + #ordinary word up-against and opening bracket - brackets are part of word. + incr word_bdepth + append word "(" + } else { + append word $char + } + } + } else { + #currently only () are used for word_bdepth - todo add all or some wordwrappers chars so that the word_bstack can have multiple active. + switch -- $char { + "(" { + incr word_bdepth + lappend word_bstack $char + append word $char + } + ")" { + incr word_bdepth -1 + set word_bstack [lrange $word_bstack 0 end-1] + append word $char + } + default { + #spaces and chars added to word as it's still in a bracketed section + append word $char + } + } + } + } + } else { + + if {$char eq "("} { + incr in_bracket + + } elseif {$char eq ")"} { + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + } elseif {[regexp {[\s]} $char]} { + # + } else { + #first char of word - look for word-wrappers + if {$char in [dict keys $wordwrappers]} { + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + set word $char + } + set in_word 1 + } + } + } else { + if {$in_word} { + if {[string length $wordwrap]} { + lassign [dict get $wordwrappers $wordwrap] _open closing endmark + if {$char eq $endmark} { + set wordwrap "" + append word $closing + lappend result $word + set word "" + set in_word 0 + } else { + append word $char + } + } else { + + if {$word_bdepth == 0} { + if {$word in $shell_specials} { + if {[regexp {[\s]} $char]} { + lappend result $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + lappend result $word + set word "" + set in_word 0 + incr in_bracket + } else { + #at end of shell-specials is another point to look for word started by a wordwrapper char + #- expect common case of things like >^/my/path^ + if {$char in [dict keys $wordwrappers]} { + lappend result $word + set word "" + set in_word 1 ;#just for explicitness.. we're straight into the next word. + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + #something unusual.. keep going with word! + append word $char + } + } + + } else { + if {[regexp {[\s)]} $char]} { + lappend result $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + incr word_bdepth + append word $char + } else { + append word $char + } + } + } else { + switch -- $char { + "(" { + incr word_bdepth + append word $char + } + ")" { + incr word_bdepth -1 + append word $char + } + default { + append word $char + } + } + } + } + } else { + if {[regexp {[\s]} $char]} { + #insig whitespace(?) + } elseif {$char eq "("} { + incr in_bracket + dict set bracketed_elements $in_bracket [list] + } elseif {$char eq ")"} { + error "unbalanced bracket - unable to proceed result so far: $result bracketed_elements:$bracketed_elements" + } else { + #first char of word - look for word-wrappers + if {$char in [dict keys $wordwrappers]} { + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + set word $char + } + set in_word 1 + } + } + } + #puts "----$bracketed_elements" + } + if {$in_bracket > 0} { + error "shellfilter::parse_cmd_brackets missing close bracket. input was '$str'" + } + if {[dict exists $bracketed_elements 0]} { + #lappend result [lindex [dict get $bracketed_elements 0] 0] + lappend result [dict get $bracketed_elements 0] + } + if {$in_word} { + lappend result $word + } + return $result + } + + #only double quote if argument not quoted with single or double quotes + proc dquote_if_not_quoted {a} { + set wrapchars [string cat [string range $a 0 0] [string range $a end end]] + switch -- $wrapchars { + {""} - {''} { + return $a + } + default { + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + } + } + + #proc dquote_if_not_bracketed/braced? + + #wrap in double quotes if not double-quoted + proc dquote_if_not_dquoted {a} { + set wrapchars [string cat [string range $a 0 0] [string range $a end end]] + switch -- $wrapchars { + {""} { + return $a + } + default { + #escape any inner quotes.. + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + } + } + proc dquote {a} { + #escape any inner quotes.. + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + proc get_scriptrun_from_cmdlist_dquote_if_not {cmdlist {shellcmdflag ""}} { + set scr [auto_execok "script"] + if {[string length $scr]} { + #set scriptrun "( $c1 [lrange $cmdlist 1 end] )" + set arg1 [lindex $cmdlist 0] + if {[string first " " $arg1]>0} { + set c1 [dquote_if_not_quoted $arg1] + #set c1 "\"$arg1\"" + } else { + set c1 $arg1 + } + + if {[string length $shellcmdflag]} { + set scriptrun "$shellcmdflag \$($c1 " + } else { + set scriptrun "\$($c1 " + } + #set scriptrun "$c1 " + foreach a [lrange $cmdlist 1 end] { + #set a [string map [list "/" "//"] $a] + #set a [string map [list "\"" "\\\""] $a] + if {[string first " " $a] > 0} { + append scriptrun [dquote_if_not_quoted $a] + } else { + append scriptrun $a + } + append scriptrun " " + } + set scriptrun [string trim $scriptrun] + append scriptrun ")" + #return [list $scr -q -e -c $scriptrun /dev/null] + return [list $scr -e -c $scriptrun /dev/null] + } else { + return $cmdlist + } + } + + proc ::shellfilter::trun {commandlist args} { + #jmn + } + + + # run a command (or tcl script) with tees applied to stdout/stderr/stdin (or whatever channels are being used) + # By the point run is called - any transforms should already be in place on the channels if they're needed. + # The tees will be inline with none,some or all of those transforms depending on how the stack was configured + # (upstream,downstream configured via -float,-sink etc) + proc ::shellfilter::run {commandlist args} { + #must be a list. If it was a shell commandline string. convert it elsewhere first. + + variable sources + set runtag "shellfilter-run" + #set tid [::shellfilter::log::open $runtag [list -syslog 127.0.0.1:514]] + set tid [::shellfilter::log::open $runtag [list -syslog ""]] + if {[catch {llength $commandlist} listlen]} { + set listlen "" + } + ::shellfilter::log::write $runtag " commandlist:'$commandlist' listlen:$listlen strlen:[string length $commandlist]" + + #flush stdout + #flush stderr + + #adding filters with sink-aside will temporarily disable the existing redirection + #All stderr/stdout from the shellcommand will now tee to the underlying stderr/stdout as well as the configured syslog + + set defaults [dict create \ + -teehandle command \ + -outchan stdout \ + -errchan stderr \ + -inchan stdin \ + -tclscript 0 \ + ] + set opts [dict merge $defaults $args] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set outchan [dict get $opts -outchan] + set errchan [dict get $opts -errchan] + set inchan [dict get $opts -inchan] + set teehandle [dict get $opts -teehandle] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set is_script [dict get $opts -tclscript] + dict unset opts -tclscript ;#don't pass it any further + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set teehandle_out ${teehandle}out ;#default commandout + set teehandle_err ${teehandle}err + set teehandle_in ${teehandle}in + + + #puts stdout "shellfilter initialising tee_to_pipe transforms for in/out/err" + + # sources should be added when stack::new called instead(?) + foreach source [list $teehandle_out $teehandle_err] { + if {$source ni $sources} { + lappend sources $source + } + } + set outdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_out device] + set outpipechan [dict get $outdeviceinfo localchan] + set errdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_err device] + set errpipechan [dict get $errdeviceinfo localchan] + + #set indeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_in device] + #set inpipechan [dict get $indeviceinfo localchan] + + #NOTE:These transforms are not necessarily at the top of each stack! + #The float/sink mechanism, along with whether existing transforms are diversionary decides where they sit. + set id_out [shellfilter::stack::add $outchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_out -pipechan $outpipechan]] + set id_err [shellfilter::stack::add $errchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_err -pipechan $errpipechan]] + + # need to use os level channel handle for stdin - try named pipes (or even sockets) instead of fifo2 for this + # If non os-level channel - the command can't be run with the redirection + # stderr/stdout can be run with non-os handles in the call - + # but then it does introduce issues with terminal-detection and behaviour for stdout at least + # + # input is also a tee - we never want to change the source at this point - just log/process a side-channel of it. + # + #set id_in [shellfilter::stack::add $inchan tee_to_pipe -action sink-aside -settings [list -tag commandin -pipechan $inpipechan]] + + + #set id_out [shellfilter::stack::add stdout tee_to_log -action sink-aside -settings [list -tag shellstdout -syslog 127.0.0.1:514 -file ""]] + #set id_err [shellfilter::stack::add stderr tee_to_log -action sink-aside -settings [list -tag shellstderr -syslog 127.0.0.1:514 -file "stderr.txt"]] + + #we need to catch errors - and ensure stack::remove calls occur. + #An error can be raised if the command couldn't even launch, as opposed to a non-zero exitcode and stderr output from the command itself. + # + if {!$is_script} { + set experiment 0 + if {$experiment} { + try { + set results [exec {*}$commandlist] + set exitinfo [list exitcode 0] + } trap CHILDSTATUS {results options} { + set exitcode [lindex [dict get $options -errorcode] 2] + set exitinfo [list exitcode $exitcode] + } + } else { + if {[catch { + #run process with stdout/stderr/stdin or with configured channels + #set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan $inpipechan {*}$opts] + set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan stdin {*}$opts] + #puts stderr "---->exitinfo $exitinfo" + + #subprocess result should usually have an "exitcode" key + #but for background execution we will get a "pids" key of process ids. + } errMsg]} { + set exitinfo [list error "$errMsg" source shellcommand_stdout_stderr] + } + } + } else { + if {[catch { + #script result + set exitinfo [list result [uplevel #0 [list eval $commandlist]]] + } errMsg]} { + set exitinfo [list error "$errMsg" errorCode $::errorCode errorInfo "$::errorInfo"] + } + } + + + #the previous redirections on the underlying inchan/outchan/errchan items will be restored from the -aside setting during removal + #Remove execution-time Tees from stack + shellfilter::stack::remove stdout $id_out + shellfilter::stack::remove stderr $id_err + #shellfilter::stack::remove stderr $id_in + + + #chan configure stderr -buffering line + #flush stdout + + + ::shellfilter::log::write $runtag " return '$exitinfo'" + ::shellfilter::log::close $runtag + return $exitinfo + } + proc ::shellfilter::logtidyup { {tags {}} } { + variable sources + set worker_errorlist [list] + set tidied_sources [list] + set tidytag "logtidy" + + + # opening a thread or writing to a log/syslog close to possible process exit is probably not a great idea. + # we should ensure the thread already exists early on if we really need logging here. + # + #set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}] + #::shellfilter::log::write $tidytag " logtidyuptags '$tags'" + + foreach s $sources { + if {$s eq $tidytag} { + continue + } + #puts "logtidyup source $s" + set close 1 + if {[llength $tags]} { + if {$s ni $tags} { + set close 0 + } + } + if {$close} { + lappend tidied_sources $s + shellfilter::log::close $s + lappend worker_errorlist {*}[shellthread::manager::get_and_clear_errors $s] + } + } + set remaining_sources [list] + foreach s $sources { + if {$s ni $tidied_sources} { + lappend remaining_sources $s + } + } + + #set sources [concat $remaining_sources $tidytag] + set sources $remaining_sources + + #shellfilter::stack::unwind stdout + #shellfilter::stack::unwind stderr + return [list tidied $tidied_sources errors $worker_errorlist] + } + + #package require tcl::chan::null + # e.g set errchan [tcl::chan::null] + # e.g chan push stdout [shellfilter::chan::var new ::some_var] + proc ::shellfilter::shellcommand_stdout_stderr {commandlist outchan errchan inchan args} { + set valid_flags [list \ + -timeout \ + -outprefix \ + -errprefix \ + -debug \ + -copytempfile \ + -outbuffering \ + -errbuffering \ + -inbuffering \ + -readprocesstranslation \ + -outtranslation \ + -stdinhandler \ + -outchan \ + -errchan \ + -inchan \ + -teehandle\ + ] + + set runtag shellfilter-run2 + #JMN - load from config + #set tid [::shellfilter::log::open $runtag [list -syslog "127.0.0.1:514"]] + set tid [::shellfilter::log::open $runtag [list -syslog ""]] + + if {[llength $args] % 2} { + error "Trailing arguments after any positional arguments must be in pairs of the form -argname argvalue. Valid flags are:'$valid_flags'" + } + set invalid_flags [list] + foreach {k -} $args { + switch -- $k { + -timeout - + -outprefix - + -errprefix - + -debug - + -copytempfile - + -outbuffering - + -errbuffering - + -inbuffering - + -readprocesstranslation - + -outtranslation - + -stdinhandler - + -outchan - + -errchan - + -inchan - + -teehandle { + } + default { + lappend invalid_flags $k + } + } + } + if {[llength $invalid_flags]} { + error "Unknown option(s)'$invalid_flags': must be one of '$valid_flags'" + } + #line buffering generally best for output channels.. keeps relative output order of stdout/stdin closer to source order + #there may be data where line buffering is inappropriate, so it's configurable per std channel + #reading inputs with line buffering can result in extraneous newlines as we can't detect trailing data with no newline before eof. + set defaults [dict create \ + -outchan stdout \ + -errchan stderr \ + -inchan stdin \ + -outbuffering none \ + -errbuffering none \ + -readprocesstranslation auto \ + -outtranslation lf \ + -inbuffering none \ + -timeout 900000\ + -outprefix ""\ + -errprefix ""\ + -debug 0\ + -copytempfile 0\ + -stdinhandler ""\ + ] + + + + set args [dict merge $defaults $args] + set outbuffering [dict get $args -outbuffering] + set errbuffering [dict get $args -errbuffering] + set inbuffering [dict get $args -inbuffering] + set readprocesstranslation [dict get $args -readprocesstranslation] + set outtranslation [dict get $args -outtranslation] + set timeout [dict get $args -timeout] + set outprefix [dict get $args -outprefix] + set errprefix [dict get $args -errprefix] + set debug [dict get $args -debug] + set copytempfile [dict get $args -copytempfile] + set stdinhandler [dict get $args -stdinhandler] + + set debugname "shellfilter-debug" + + if {$debug} { + set tid [::shellfilter::log::open $debugname [list -syslog "127.0.0.1:514"]] + ::shellfilter::log::write $debugname " commandlist '$commandlist'" + } + #'clock micros' good enough id for shellcommand calls unless one day they can somehow be called concurrently or sequentially within a microsecond and within the same interp. + # a simple counter would probably work too + #consider other options if an alternative to the single vwait in this function is used. + set call_id [tcl::clock::microseconds] ; + set ::shellfilter::shellcommandvars($call_id,exitcode) "" + set ::shellfilter::shellcommandvars($call_id,timeoutid) "" + set waitvar ::shellfilter::shellcommandvars($call_id,waitvar) + if {$debug} { + ::shellfilter::log::write $debugname " waitvar '$waitvar'" + } + lassign [chan pipe] rderr wrerr + chan configure $wrerr -blocking 0 + + set custom_stderr "" + set lastitem [lindex $commandlist end] + #todo - ensure we can handle 2> file (space after >) + + #review - reconsider the handling of redirections such that tcl-style are handled totally separately to other shell syntaxes! + # + #note 2>@1 must ocur as last word for tcl - but 2@stdout can occur elsewhere + #(2>@stdout echoes to main stdout - not into pipeline) + #To properly do pipelines it looks like we will have to split on | and call this proc multiple times and wire it up accordingly (presumably in separate threads) + + switch -- [string trim $lastitem] { + {&} { + set name [lindex $commandlist 0] + #background execution - stdout and stderr from child still comes here - but process is backgrounded + #FIX! - this is broken for paths with backslashes for example + #set pidlist [exec {*}[concat $name [lrange $commandlist 1 end]]] + set pidlist [exec {*}$commandlist] + return [list pids $pidlist] + } + {2>&1} - {2>@1} { + set custom_stderr {2>@1} ;#use the tcl style + set commandlist [lrange $commandlist 0 end-1] + } + default { + # 2> filename + # 2>> filename + # 2>@ openfileid + set redir2test [string range $lastitem 0 1] + if {$redir2test eq "2>"} { + set custom_stderr $lastitem + set commandlist [lrange $commandlist 0 end-1] + } + } + } + set lastitem [lindex $commandlist end] + + set teefile "" ;#empty string, write, append + #an ugly hack.. because redirections seem to arrive wrapped - review! + #There be dragons here.. + #Be very careful with list manipulation of the commandlist string.. backslashes cause havoc. commandlist must always be a well-formed list. generally avoid string manipulations on entire list or accidentally breaking a list element into parts if it shouldn't be.. + #The problem here - is that we can't always know what was intended on the commandline regarding quoting + + ::shellfilter::log::write $runtag "checking for redirections in $commandlist" + #sometimes we see a redirection without a following space e.g >C:/somewhere + #normalize + switch -regexp -- $lastitem\ + {^>[/[:alpha:]]+} { + set lastitem "> [string range $lastitem 1 end]" + }\ + {^>>[/[:alpha:]]+} { + set lastitem ">> [string range $lastitem 2 end]" + } + + + #for a redirection, we assume either a 2-element list at tail of form {> {some path maybe with spaces}} + #or that the tail redirection is not wrapped.. x y z > {some path maybe with spaces} + #we can't use list methods such as llenth on a member of commandlist + set wordlike_parts [regexp -inline -all {\S+} $lastitem] + + if {([llength $wordlike_parts] >= 2) && ([lindex $wordlike_parts 0] in [list ">>" ">"])} { + #wrapped redirection - but maybe not 'well' wrapped (unquoted filename) + set lastitem [string trim $lastitem] ;#we often see { > something} + + #don't use lassign or lrange on the element itself without checking first + #we can treat the commandlist as a whole as a well formed list but not neccessarily each element within. + #lassign $lastitem redir redirtarget + #set commandlist [lrange $commandlist 0 end-1] + # + set itemchars [split $lastitem ""] + set firstchar [lindex $itemchars 0] + set lastchar [lindex $itemchars end] + + #NAIVE test for double quoted only! + #consider for example {"a" x="b"} + #testing first and last is not decisive + #We need to decide what level of drilling down is even appropriate here.. + #if something was double wrapped - it was perhaps deliberate so we don't interpret it as something(?) + set head_tail_chars [list $firstchar $lastchar] + set doublequoted [expr {[llength [lsearch -all $head_tail_chars "\""]] == 2}] + if {[string equal "\{" $firstchar] && [string equal "\}" $lastchar]} { + set curlyquoted 1 + } else { + set curlyquoted 0 + } + + if {$curlyquoted} { + #these are not the tcl protection brackets but ones supplied in the argument + #it's still not valid to use list operations on a member of the commandlist + set inner [string range $lastitem 1 end-1] + #todo - fix! we still must assume there could be list-breaking data! + set innerwords [regexp -inline -all {\S+} $inner] ;#better than [split $inner] because we don't get extra empty elements for each whitespace char + set redir [lindex $innerwords 0] ;#a *potential* redir - to be tested below + set redirtarget [lrange $innerwords 1 end] ;#all the rest + } elseif {$doublequoted} { + ::shellfilter::log::write $debugname "doublequoting at tail of command '$commandlist'" + set inner [string range $lastitem 1 end-1] + set innerwords [regexp -inline -all {\S+} $inner] + set redir [lindex $innerwords 0] + set redirtarget [lrange $innerwords 1 end] + } else { + set itemwords [regexp -inline -all {\S+} $lastitem] + # e.g > c:\test becomes > {c:\test} + # but > c/mnt/c/test/temp.txt stays as > /mnt/c/test/temp.txt + set redir [lindex $itemwords 0] + set redirtarget [lrange $itemwords 1 end] + } + set commandlist [lrange $commandlist 0 end-1] + + } elseif {[lindex $commandlist end-1] in [list ">>" ">"]} { + #unwrapped redirection + #we should be able to use list operations like lindex and lrange here as the command itself is hopefully still a well formed list + set redir [lindex $commandlist end-1] + set redirtarget [lindex $commandlist end] + set commandlist [lrange $commandlist 0 end-2] + } else { + #no redirection + set redir "" + set redirtarget "" + #no change to command list + } + + + switch -- $redir { + ">>" - ">" { + set redirtarget [string trim $redirtarget "\""] + ::shellfilter::log::write $runtag " have redirection '$redir' to '$redirtarget'" + + set winfile $redirtarget ;#default assumption + switch -glob -- $redirtarget { + "/c/*" { + set winfile "c:/[string range $redirtarget 3 end]" + } + "/mnt/c/*" { + set winfile "c:/[string range $redirtarget 7 end]" + } + } + + if {[file exists [file dirname $winfile]]} { + #containing folder for target exists + if {$redir eq ">"} { + set teefile "write" + } else { + set teefile "append" + } + ::shellfilter::log::write $runtag "Directory exists '[file dirname $winfile]' operation:$teefile" + } else { + #we should be writing to a file.. but can't + ::shellfilter::log::write $runtag "cannot verify directory exists '[file dirname $winfile]'" + } + } + default { + ::shellfilter::log::write $runtag "No redir found!!" + } + } + + #often first element of command list is wrapped and cannot be run directly + #e.g {{ls -l} {> {temp.tmp}}} + #we will assume that if there is a single element which is a pathname containing a space - it is doubly wrapped. + # this may not be true - and the command may fail if it's just {c:\program files\etc} but it is the less common case and we currently have no way to detect. + #unwrap first element.. will not affect if not wrapped anyway (subject to comment above re spaces) + set commandlist [concat [lindex $commandlist 0] [lrange $commandlist 1 end]] + + #todo? + #child process environment. + # - to pass a different environment to the child - we would need to save the env array, modify as required, and then restore the env array. + + #to restore buffering states after run + set remember_in_out_err_buffering [list \ + [chan configure $inchan -buffering] \ + [chan configure $outchan -buffering] \ + [chan configure $errchan -buffering] \ + ] + + set remember_in_out_err_translation [list \ + [chan configure $inchan -translation] \ + [chan configure $outchan -translation] \ + [chan configure $errchan -translation] \ + ] + + + + + #chan configure $inchan -buffering none -blocking 1 ;#test + chan configure $inchan -buffering $inbuffering -blocking 0 ;#we are setting up a readable handler for this - so non-blocking ok + + + chan configure $errchan -buffering $errbuffering + #chan configure $outchan -blocking 0 + chan configure $outchan -buffering $outbuffering ;#don't configure non-blocking. weird duplicate of *second* line occurs if you do. + # + + #-------------------------------------------- + #Tested on windows. Works to stop in output when buffering is none, reading from channel with -translation auto + #cmd, pwsh, tcl + #chan configure $outchan -translation lf + #chan configure $errchan -translation lf + #-------------------------------------------- + chan configure $outchan -translation $outtranslation + chan configure $errchan -translation $outtranslation + + #puts stderr "chan configure $wrerr [chan configure $wrerr]" + if {$debug} { + ::shellfilter::log::write $debugname "COMMAND [list $commandlist] strlen:[string length $commandlist] llen:[llength $commandlist]" + } + #todo - handle custom redirection of stderr to a file? + if {[string length $custom_stderr]} { + #::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist $custom_stderr] a+" + #set rdout [open |[concat $commandlist $custom_stderr] a+] + ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list $custom_stderr <@$inchan]] [list RDONLY]" + set rdout [open |[concat $commandlist [list <@$inchan $custom_stderr]] [list RDONLY]] + set rderr "bogus" ;#so we don't wait for it + } else { + ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]" + #set rdout [open |[concat $commandlist [list 2>@$wrerr]] a+] + #set rdout [open |[concat $commandlist [list 2>@$wrerr]] [list RDWR]] + + # If we don't redirect stderr to our own tcl-based channel - then the transforms don't get applied. + # This is the whole reason we need these file-event loops. + # Ideally we need something like exec,open in tcl that interacts with transformed channels directly and emits as it runs, not only at termination + # - and that at least appears like a terminal to the called command. + #set rdout [open |[concat $commandlist [list 2>@stderr <@$inchan]] [list RDONLY]] + + #REVIEW! + #if the child process takes a while to begin reading stdin - the data on stdin between when we stopped the parent chan event handler and when the child gets data, + #seems to stay buffered somewhere. It is then read by the parent, after the child returns. (ie not lost, but out-of-order) + #This can be apparent sometimes even with fast typing upon calling an executable. (e.g occasionally even vim - but seems to be timing based so might only happen first time if at all) + # see scriptlib/stdin_race.tcl etc test files. + #similar problem with python & perl - issue seems to be in libc or OS buffering behaviour for standard channels. + #note that zig (repo/jn/zig/stdin_race) seems to avoid this issue - todo - make zig based binary extension for open/exec? + + set rdout [open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]] + + chan configure $rderr -buffering $errbuffering -blocking 0 + chan configure $rderr -translation $readprocesstranslation + } + + + + set command_pids [pid $rdout] + #puts stderr "command_pids: $command_pids" + #tcl::process ensemble only available in 8.7+ - and it didn't prove useful here anyway + # the child process generally won't shut down until channels are closed. + # premature EOF on grandchild process launch seems to be due to lack of terminal emulation when redirecting stdin/stdout. + # worked around in punk/repl using 'script' command as a fake tty. + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $command_pids 0] ni $subprocesses} { + # puts stderr "pid [lindex $command_pids 0] not running $errMsg" + #} else { + # puts stderr "pid [lindex $command_pids 0] is running" + #} + + + if {$debug} { + ::shellfilter::log::write $debugname "pipeline pids: $command_pids" + } + + #jjj + + + chan configure $rdout -buffering $outbuffering -blocking 0 + chan configure $rdout -translation $readprocesstranslation + + if {![string length $custom_stderr]} { + chan event $rderr readable [list apply {{chan other wrerr outchan errchan waitfor errprefix errbuffering debug debugname pids} { + if {$errbuffering eq "line"} { + set countchunk [chan gets $chan chunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + #errprefix only applicable to line buffered output + if {$countchunk >= 0} { + if {[chan eof $chan]} { + puts -nonewline $errchan ${errprefix}$chunk + } else { + puts $errchan "${errprefix}$chunk" + } + } + } else { + set chunk [chan read $chan] + if {[string length $chunk]} { + puts -nonewline $errchan $chunk + } + } + if {[chan eof $chan]} { + flush $errchan ;#jmn + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $pids 0] ni $subprocesses} { + # puts stderr "stderr reader: pid [lindex $pids 0] no longer running" + #} else { + # puts stderr "stderr reader: pid [lindex $pids 0] still running" + #} + chan close $chan + #catch {chan close $wrerr} + #if {$other ni [chan names]} { + # set $waitfor stderr + #} + if {[catch {chan configure $other}]} { + set $waitfor stderr + } + } + }} $rderr $rdout $wrerr $outchan $errchan $waitvar $errprefix $errbuffering $debug $debugname $command_pids] + } + + #todo - handle case where large amount of stdin coming in faster than rdout can handle + #as is - arbitrary amount of memory could be used because we aren't using a filevent for rdout being writable + # - we're just pumping it in to the non-blocking rdout buffers + # ie there is no backpressure and stdin will suck in as fast as possible. + # for most commandlines this probably isn't too big a deal.. but it could be a problem for multi-GB disk images etc + # + # + + ## Note - detecting trailing missing nl before eof is basically the same here as when reading rdout from executable + # - but there is a slight difference in that with rdout we get an extra blocked state just prior to the final read. + # Not known if that is significant + ## with inchan configured -buffering line + #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl -r cat + #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl -r cat + #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:1 pend:-1 count:3 + #etc + + if 0 { + chan event $inchan readable [list apply {{chan wrchan inbuffering waitfor} { + #chan copy stdin $chan ;#doesn't work in a chan event + if {$inbuffering eq "line"} { + set countchunk [chan gets $chan chunk] + #puts $wrchan "stdinstate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + if {$countchunk >= 0} { + if {[chan eof $chan]} { + puts -nonewline $wrchan $chunk + } else { + puts $wrchan $chunk + } + } + } else { + set chunk [chan read $chan] + if {[string length $chunk]} { + puts -nonewline $wrchan $chunk + } + } + if {[chan eof $chan]} { + puts stderr "|stdin_reader>eof [chan configure stdin]" + chan event $chan readable {} + #chan close $chan + chan close $wrchan write ;#half close + #set $waitfor "stdin" + } + }} $inchan $rdout $inbuffering $waitvar] + + if {[string length $stdinhandler]} { + chan configure stdin -buffering line -blocking 0 + chan event stdin readable $stdinhandler + } + } + + set actual_proc_out_buffering [chan configure $rdout -buffering] + set actual_outchan_buffering [chan configure $outchan -buffering] + #despite whatever is configured - we match our reading to how we need to output + set read_proc_out_buffering $actual_outchan_buffering + + + + if {[string length $teefile]} { + set logname "redir_[string map {: _} $winfile]_[tcl::clock::microseconds]" + set tid [::shellfilter::log::open $logname {-syslog 127.0.0.1:514}] + if {$teefile eq "write"} { + ::shellfilter::log::write $logname "opening '$winfile' for write" + set fd [open $winfile w] + } else { + ::shellfilter::log::write $logname "opening '$winfile' for appending" + set fd [open $winfile a] + } + #chan configure $fd -translation lf + chan configure $fd -translation $outtranslation + chan configure $fd -encoding utf-8 + + set tempvar_bytetotal [namespace current]::totalbytes[tcl::clock::microseconds] + set $tempvar_bytetotal 0 + chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname writefile writefilefd copytempfile bytevar logtag} { + #review - if we write outprefix to normal stdout.. why not to redirected file? + #usefulness of outprefix is dubious + upvar $bytevar totalbytes + if {$read_proc_out_buffering eq "line"} { + #set outchunk [chan read $chan] + set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + if {$countchunk >= 0} { + if {![chan eof $chan]} { + set numbytes [expr {[string length $outchunk] + 1}] ;#we are assuming \n not \r\n - but count won't/can't be completely accurate(?) - review + puts $writefilefd $outchunk + } else { + set numbytes [string length $outchunk] + puts -nonewline $writefilefd $outchunk + } + incr totalbytes $numbytes + ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" + #puts $outchan "${outprefix} wrote $numbytes bytes to $writefile" + } + } else { + set outchunk [chan read $chan] + if {[string length $outchunk]} { + puts -nonewline $writefilefd $outchunk + set numbytes [string length $outchunk] + incr totalbytes $numbytes + ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" + } + } + if {[chan eof $chan]} { + flush $writefilefd ;#jmn + #set blocking so we can get exit code + chan configure $chan -blocking 1 + catch {::shellfilter::log::write $logtag "${outprefix} total bytes $totalbytes written to $writefile"} + #puts $outchan "${outprefix} total bytes $totalbytes written to $writefile" + catch {close $writefilefd} + if {$copytempfile} { + catch {file copy $writefile "[file rootname $writefile]_copy[file extension $writefile]"} + } + try { + chan close $chan + set ::shellfilter::shellcommandvars($call_id,exitcode) 0 + if {$debug} { + ::shellfilter::log::write $debugname "(teefile) -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + if {$debug} { + ::shellfilter::log::write $debugname "(teefile) CHILD PROCESS EXITED with code: $code" + } + set ::shellfilter::shellcommandvars($call_id,exitcode) $code + } + catch {chan close $wrerr} + #if {$other ni [chan names]} { + # set $waitfor stdout + #} + if {[catch {chan configure $other}]} { + set $waitfor stdout + } + } + }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $winfile $fd $copytempfile $tempvar_bytetotal $logname] + + } else { + + # This occurs when we have outbuffering set to 'line' - as the 'input' from rdout which comes from the executable is also configured to 'line' + # where b:0|1 is whether chan blocked $chan returns 0 or 1 + # pend is the result of chan pending $chan + # eof is the resot of chan eof $chan + + + ##------------------------- + ##If we still read with gets,to retrieve line by line for output to line-buffered output - but the input channel is configured with -buffering none + ## then we can detect the difference + # there is an extra blocking read - but we can stil use eof with data to detect the absent newline and avoid passing an extra one on. + #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /u/c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:1 eof:0 pend:-1 count:-1 + #instate b:0 eof:1 pend:-1 count:3 + #etc + ##------------------------ + + + #this should only occur if upstream is coming from stdin reader that has line buffering and hasn't handled the difference properly.. + ###reading with gets from line buffered input with trailing newline + #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + ###reading with gets from line buffered input with trailing newline + ##No detectable difference! + #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + ##------------------------- + + #Note that reading from -buffering none and writing straight out gives no problem because we pass the newlines through as is + + + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($rdout) 0 ;#a very specific case of readblocked prior to eof.. possibly not important + #this detection is disabled for now - but left for debugging in case it means something.. or changes + chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname pids} { + #set outchunk [chan read $chan] + + if {$read_proc_out_buffering eq "line"} { + set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + #countchunk can be -1 before eof e.g when blocked + #debugging output inline with data - don't leave enabled + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + if {$countchunk >= 0} { + if {![chan eof $chan]} { + puts $outchan ${outprefix}$outchunk + } else { + puts -nonewline $outchan ${outprefix}$outchunk + #if {$::shellfilter::chan::lastreadblocked_nodata_noeof($chan)} { + # seems to be the usual case + #} else { + # #false alarm, or ? we've reached eof with data but didn't get an empty blocking read just prior + # #Not known if this occurs + # #debugging output inline with data - don't leave enabled + # puts $outchan "!!!prev read didn't block: instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + #} + } + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) 0 + } else { + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) [expr {[chan blocked $chan] && ![chan eof $chan]}] + } + } else { + #puts $outchan "read CHANNEL $chan [chan configure $chan]" + #puts $outchan "write CHANNEL $outchan b:[chan configure $outchan -buffering] t:[chan configure $outchan -translation] e:[chan configure $outchan -encoding]" + set outchunk [chan read $chan] + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:[string length $outchunk]" + if {[string length $outchunk]} { + #set stringrep [encoding convertfrom utf-8 $outchunk] + #set newbytes [encoding convertto utf-16 $stringrep] + #puts -nonewline $outchan $newbytes + puts -nonewline $outchan $outchunk + } + } + + if {[chan eof $chan]} { + flush $outchan ;#jmn + #for now just look for first element in the pid list.. + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $pids 0] ni $subprocesses} { + # puts stderr "stdout reader pid: [lindex $pids 0] no longer running" + #} else { + # puts stderr "stdout reader pid: [lindex $pids 0] still running" + #} + + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan]" + chan configure $chan -blocking 1 ;#so we can get exit code + try { + chan close $chan + set ::shellfilter::shellcommandvars($call_id,exitcode) 0 + if {$debug} { + ::shellfilter::log::write $debugname " -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + set ::shellfilter::shellcommandvars($call_id,exitcode) $code + if {$debug} { + ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with code: $code" + } + } trap CHILDKILLED {result options} { + #set code [lindex [dict get $options -errorcode] 2] + #set ::shellfilter::shellcommandvars(%id%,exitcode) $code + set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled" + if {$debug} { + ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with result:'$result' options:'$options'" + } + + } finally { + #puts stdout "HERE" + #flush stdout + + } + catch {chan close $wrerr} + #if {$other ni [chan names]} { + # set $waitfor stdout + #} + if {[catch {chan configure $other}]} { + set $waitfor stdout + } + + } + }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $command_pids] + } + + #todo - add ability to detect activity/data-flow and change timeout to only apply for period with zero data + #e.g x hrs with no data(?) + #reset timeout when data detected. + #review - stdin??? + set ::shellfilter::shellcommandvars($call_id,timeoutid) [after $timeout [string map [list %cpids% $command_pids %w% $waitvar %id% $call_id %wrerr% $wrerr %rdout% $rdout %rderr% $rderr %debug% $debug %debugname% $debugname] { + if {[info exists ::shellfilter::shellcommandvars(%id%,exitcode)]} { + #killing the task (on windows) doesn't seem to work if done after we close the output channels + catch {puts stderr "timeout - closing.";flush stderr} + set command_pids "{%cpids%}" + if {[llength $command_pids]} { + set pid [lindex $command_pids 0] + if {$::tcl_platform(platform) eq "windows"} { + set killcmd [list [auto_execok taskkill] /F /PID $pid] + } else { + #set killcmd [list kill -9 $pid] + set killcmd [list kill -TERM $pid] + } + if {[catch { + exec {*}$killcmd + } errM]} { + puts stderr "Failed to kill '$pid': errMsg $errM" + flush stderr + } + } + if {[set ::shellfilter::shellcommandvars(%id%,exitcode)] ne ""} { + catch { chan close %wrerr% } + catch { chan close %rdout%} + catch { chan close %rderr%} + } else { + chan configure %rdout% -blocking 1 + try { + chan close %rdout% + set ::shellfilter::shellcommandvars(%id%,exitcode) 0 + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) CHILD PROCESS EXITED with code: $code" + } + set ::shellfilter::shellcommandvars(%id%,exitcode) $code + } trap CHILDKILLED {result options} { + set code [lindex [dict get $options -errorcode] 2] + #set code [dict get $options -code] + #set ::shellfilter::shellcommandvars(%id%,exitcode) $code + #set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled-timeout" + set ::shellfilter::shellcommandvars(%id%,exitcode) "childkilled-timeout" + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) CHILDKILLED with code: $code" + ::shellfilter::log::write %debugname% "(timeout) result:$result options:$options" + } + + } + catch { chan close %wrerr% } + catch { chan close %rderr%} + } + set %w% "timeout" + } + }]] + + + vwait $waitvar + after cancel $::shellfilter::shellcommandvars($call_id,timeoutid) + + #puts stderr "waitvar:[set $waitvar]" + #flush stderr + #if {[set $waitvar] eq "timeout"} { + # #note: attempting to kill a process here (after channels closed) doesn't work (on windows at least) + # puts stderr "command_pids: $command_pids" + # flush stderr + #} + + set exitcode [set ::shellfilter::shellcommandvars($call_id,exitcode)] + if {![string is digit -strict $exitcode]} { + puts stderr "Process exited with non-numeric code: $exitcode closed_by:[set $waitvar]" + flush stderr + } + if {[string length $teefile]} { + #cannot be called from within an event handler above.. vwait reentrancy etc + catch {::shellfilter::log::close $logname} + } + + if {$debug} { + ::shellfilter::log::write $debugname " closed by: [set $waitvar] with exitcode: $exitcode" + catch {::shellfilter::log::close $debugname} + } + array unset ::shellfilter::shellcommandvars $call_id,* + + + #restore buffering to pre shellfilter::run state + lassign $remember_in_out_err_buffering bin bout berr + chan configure $inchan -buffering $bin + chan configure $outchan -buffering $bout + chan configure $errchan -buffering $berr + + lassign $remember_in_out_err_translation tin tout terr + chan configure $inchan -translation $tin + chan configure $outchan -translation $tout + chan configure $errchan -translation $terr + + + #in channel probably closed..(? review - should it be?) + catch { + chan configure $inchan -buffering $bin + } + + + return [list exitcode $exitcode] + } + +} + +package provide shellfilter [namespace eval shellfilter { + variable version + set version 999999.0a1.0 +}] diff --git a/src/modules/shellfilter-buildversion.txt b/src/modules/shellfilter-buildversion.txt new file mode 100644 index 00000000..5e50bcd0 --- /dev/null +++ b/src/modules/shellfilter-buildversion.txt @@ -0,0 +1,3 @@ +0.2.1 +#First line must be a semantic version number +#all other lines are ignored. \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm index 3071ebd3..d776aba3 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm @@ -11069,8 +11069,8 @@ tcl::namespace::eval punk::args::argdocbase { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::args::package { variable PUNKARGS + # @dynamic not required? lappend PUNKARGS [list { - @dynamic @id -id "::punk::args::package::standard_about" @cmd -name "%pkg%::about" -help\ "About %pkg% diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.1.tm new file mode 100644 index 00000000..7b1098f3 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.1.tm @@ -0,0 +1,3348 @@ +#copyright 2023 Julian Marcel Noble +#license: BSD (revised 3-clause) +# +#Note shellfilter is currently only directly useful for unidirectional channels e.g stdin,stderr,stdout, or for example fifo2 where only one direction is being used. +#To generalize this to bidrectional channels would require shifting around read & write methods on transform objects in a very complicated manner. +#e.g each transform would probably be a generic transform container which holds sub-objects to which read & write are indirected. +#This is left as a future exercise...possibly it's best left as a concept for uni-directional channels anyway +# - as presumably the reads/writes from a bidirectional channel could be diverted off to unidirectional pipelines for processing with less work +# (and maybe even better speed/efficiency if the data volume is asymmetrical and there is significant processing on one direction) +# + + +tcl::namespace::eval shellfilter::log { + variable allow_adhoc_tags 1 + variable open_logs [tcl::dict::create] + variable is_enabled 0 + + proc disable {} { + variable is_enabled + set is_enabled 0 + proc ::shellfilter::log::open {tag settingsdict} {} + proc ::shellfilter::log::write {tag msg} {} + proc ::shellfilter::log::write_sync {tag msg} {} + proc ::shellfilter::log::close {tag} {} + } + + proc enable {} { + variable is_enabled + set is_enabled 1 + #'tag' is an identifier for the log source. + # each tag will use it's own thread to write to the configured log target + proc ::shellfilter::log::open {tag {settingsdict {}}} { + upvar ::shellfilter::sources sourcelist + if {![dict exists $settingsdict -tag]} { + tcl::dict::set settingsdict -tag $tag + } else { + #review + if {$tag ne [tcl::dict::get $settingsdict -tag]} { + error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" + } + } + if {$tag ni $sourcelist} { + lappend sourcelist $tag + } + + #note new_worker + set worker_tid [shellthread::manager::new_worker $tag $settingsdict] + #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" + return $worker_tid + } + proc ::shellfilter::log::write {tag msg} { + upvar ::shellfilter::sources sourcelist + variable allow_adhoc_tags + if {!$allow_adhoc_tags} { + if {$tag ni $sourcelist} { + error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag , and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags" + } + } + shellthread::manager::write_log $tag $msg + } + #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written + proc ::shellfilter::log::write_sync {tag msg} { + shellthread::manager::write_log $tag $msg -async 0 + } + proc ::shellfilter::log::close {tag} { + #shellthread::manager::close_worker $tag + shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed + } + + } + + #review + #configure whether we can call shellfilter::log::write without having called open first + proc require_open {{is_open_required {}}} { + variable allow_adhoc_tags + if {![string length $is_open_required]} { + return $allow_adhoc_tags + } else { + #why not use string is boolean? + set truevalues [list y yes true 1] + set falsevalues [list n no false 0] + if {[string tolower $is_open_required] in $truevalues} { + set allow_adhoc_tags 1 + } elseif {[string tolower $is_open_required] in $falsevalues} { + set allow_adhoc_tags 0 + } else { + error "shellfilter::log::require_open unrecognised value '$is_open_required' try one of $truevalues or $falsevalues" + } + } + } + if {[catch {package require shellthread}]} { + shellfilter::log::disable + } else { + shellfilter::log::enable + } + +} +namespace eval shellfilter::pipe { + #write channel for program. workerthread reads other end of fifo2 and writes data somewhere + proc open_out {tag_pipename {pipesettingsdict {}}} { + set defaultsettings {-buffering full} + set settingsdict [dict merge $defaultsettings $pipesettingsdict] + package require shellthread + #we are only using the fifo in a single direction to pipe to another thread + # - so whilst wchan and rchan could theoretically each be both read & write we're only using them for one operation each + if {![catch {package require Memchan}]} { + lassign [fifo2] wchan rchan + } else { + package require tcl::chan::fifo2 + lassign [tcl::chan::fifo2] wchan rchan + } + #default -translation for both types of fifo on windows is {auto crlf} + # -encoding is as per '[encoding system]' on the platform - e.g utf-8 (e.g windows when beta-utf8 enabled) + chan configure $wchan -buffering [dict get $settingsdict -buffering] ;# + #application end must not be binary for our filters to operate on it + + + #chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation binary ;#works reasonably.. + chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation lf + + set worker_tid [shellthread::manager::new_pipe_worker $tag_pipename $settingsdict] + #puts stderr "worker_tid: $worker_tid" + + #set_read_pipe does the thread::transfer of the rchan end. -buffering setting is maintained during thread transfer + shellthread::manager::set_pipe_read_from_client $tag_pipename $worker_tid $rchan + + set pipeinfo [list localchan $wchan remotechan $rchan workertid $worker_tid direction out] + return $pipeinfo + } + + #read channel for program. workerthread writes to other end of fifo2 from whereever it's reading (stdin, file?) + proc open_in {tag_pipename {settingsdict {} }} { + package require shellthread + package require tcl::chan::fifo2 + lassign [tcl::chan::fifo2] wchan rchan + set program_chan $rchan + set worker_chan $wchan + chan configure $worker_chan -buffering [dict get $settingsdict -buffering] + chan configure $program_chan -buffering [dict get $settingsdict -buffering] + + chan configure $program_chan -blocking 0 + chan configure $worker_chan -blocking 0 + set worker_tid [shellthread::manager::new_worker $tag_pipename $settingsdict] + + shellthread::manager::set_pipe_write_to_client $tag_pipename $worker_tid $worker_chan + + set pipeinfo [list localchan $program_chan remotechan $worker_chan workertid $worker_tid direction in] + puts stderr "|jn>pipe::open_in returning $pipeinfo" + puts stderr "program_chan: [chan conf $program_chan]" + return $pipeinfo + } + +} + + +namespace eval shellfilter::chan { + set testobj ::shellfilter::chan::var + if {$testobj ni [info commands $testobj]} { + + oo::class create var { + variable o_datavar + variable o_trecord + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + set varname [dict get $settingsdict -varname] + set o_datavar $varname + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 1 ;# as a var is diversionary - default it to be a jucntion + } + } + method initialize {ch mode} { + return [list initialize finalize write] + } + method finalize {ch} { + my destroy + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {ch count} { + # return ? + #} + method write {ch bytes} { + set stringdata [encoding convertfrom $o_enc $bytes] + append $o_datavar $stringdata + return "" + } + method meta_is_redirection {} { + return $o_is_junction + } + method meta_buffering_supported {} { + return [list line full none] + } + } + + #todo - something similar for multiple grep specs each with own -pre & -post .. store to dict? + oo::class create tee_grep_to_var { + variable o_datavar + variable o_lastxlines + variable o_trecord + variable o_grepfor + variable o_prelines + variable o_postlines + variable o_postcountdown + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_lastxlines [list] + set o_postcountdown 0 + set defaults [tcl::dict::create -pre 1 -post 1] + set settingsdict [tcl::dict::get $tf -settings] + set settings [tcl::dict::merge $defaults $settingsdict] + set o_datavar [tcl::dict::get $settings -varname] + set o_grepfor [tcl::dict::get $settings -grep] + set o_prelines [tcl::dict::get $settings -pre] + set o_postlines [tcl::dict::get $settings -post] + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize finalize write] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #method read {transform_handle count} { + # return ? + #} + method write {transform_handle bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set lastx $o_lastxlines + lappend o_lastxlines $logdata + + if {$o_postcountdown > 0} { + append $o_datavar $logdata + if {[regexp $o_grepfor $logdata]} { + #another match in postlines + set o_postcountdown $o_postlines + } else { + incr o_postcountdown -1 + } + } else { + if {[regexp $o_grepfor $logdata]} { + append $o_datavar [join $lastx] + append $o_datavar $logdata + set o_postcountdown $o_postlines + } + } + + if {[llength $o_lastxlines] > $o_prelines} { + set o_lastxlines [lrange $o_lastxlines 1 end] + } + return $bytes + } + method meta_is_redirection {} { + return $o_is_junction + } + method meta_buffering_supported {} { + return [list line] + } + } + + oo::class create tee_to_var { + variable o_datavars + variable o_trecord + variable o_enc + variable o_encbuf + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_encbuf "" + set settingsdict [tcl::dict::get $tf -settings] + set varname [tcl::dict::get $settingsdict -varname] + set o_datavars $varname + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {ch mode} { + return [list initialize finalize write flush clear] + } + method finalize {ch} { + my destroy + } + method clear {ch} { + return + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {ch count} { + # return ? + #} + #method flush {ch} { + # return "" + #} + method flush {transform_handle} { + #puts stdout "" + #review - just clear o_encbuf and emit nothing? + #we wouldn't have a value there if it was convertable from the channel encoding? + set clear $o_encbuf + set o_encbuf "" + return $o_encbuf + } + method write {ch bytes} { + #test with set x [string repeat " \U1f6c8" 2043] + #or + #test with set x [string repeat " \U1f6c8" 683] + #most windows terminals (at least) may emit two unrecognised chars "??" at the end + + #Our goal with the while loop here is to avoid encoding conversion errors + #the source of the bogus chars in terminals is unclear. + #Alacritty on windows doesn't seem to have the problem, but wezterm,cmd,windows terminal do. + + #set stringdata [tcl::encoding::convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [string length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [string range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + + foreach v $o_datavars { + append $v $stringdata + } + #return $bytes + return [string range $inputbytes 0 end-$tail_offset] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + oo::class create tee_to_pipe { + variable o_logsource + variable o_localchan + variable o_enc + variable o_encbuf + variable o_trecord + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_encbuf "" + set settingsdict [tcl::dict::get $tf -settings] + if {![dict exists $settingsdict -tag]} { + error "tee_to_pipe constructor settingsdict missing -tag" + } + set o_localchan [tcl::dict::get $settingsdict -pipechan] + set o_logsource [tcl::dict::get $settingsdict -tag] + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize read drain write flush clear finalize] + } + method finalize {transform_handle} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {transform_handle events} { + # must be present but we ignore it because we do not + # post any events + } + method clear {transform_handle} { + return + } + method drain {transform_handle} { + return "" + } + method read {transform_handle bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + #::shellfilter::log::write $o_logsource $logdata + puts -nonewline $o_localchan $logdata + return $bytes + } + method flush {transform_handle} { + #return "" + set clear $o_encbuf + set o_encbuf "" + return $o_encbuf + } + method write {transform_handle bytes} { + #set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + #::shellfilter::log::write $o_logsource $logdata + puts -nonewline $o_localchan $stringdata + #return $bytes + return [::tcl::string::range $inputbytes 0 end-$tail_offset] + } + #a tee is not a redirection - because data still flows along the main path + method meta_is_redirection {} { + return $o_is_junction + } + + } + oo::class create tee_to_log { + variable o_tid + variable o_logsource + variable o_trecord + variable o_enc + variable o_encbuf + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_encbuf "" + set settingsdict [tcl::dict::get $tf -settings] + if {![tcl::dict::exists $settingsdict -tag]} { + error "tee_to_log constructor settingsdict missing -tag" + } + set o_logsource [tcl::dict::get $settingsdict -tag] + set o_tid [::shellfilter::log::open $o_logsource $settingsdict] + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {ch mode} { + return [list initialize read write flush finalize] + } + method finalize {ch} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + method read {ch bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + ::shellfilter::log::write $o_logsource $logdata + return $bytes + } + method flush {transform_handle} { + #return "" + set clear $o_encbuf + set o_encbuf "" + return $o_encbuf + } + method write {ch bytes} { + #set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + set bytes [::tcl::string::range $inputbytes 0 end-$tail_offset] + ::shellfilter::log::write $o_logsource $stringdata + return $bytes + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + + oo::class create logonly { + variable o_tid + variable o_logsource + variable o_trecord + variable o_enc + variable o_encbuf + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set o_encbuf "" + set settingsdict [dict get $tf -settings] + if {![dict exists $settingsdict -tag]} { + error "logonly constructor settingsdict missing -tag" + } + set o_logsource [dict get $settingsdict -tag] + set o_tid [::shellfilter::log::open $o_logsource $settingsdict] + } + method initialize {transform_handle mode} { + return [list initialize finalize write] + } + method finalize {transform_handle} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {transform_handle events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {transform_handle count} { + # return ? + #} + method write {transform_handle bytes} { + #set logdata [encoding convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return + } + } + + #::shellfilter::log::write_sync $o_logsource $logdata + ::shellfilter::log::write $o_logsource $stringdata + return + } + method meta_is_redirection {} { + return 1 + } + } + + #review - we should probably provide a more narrow filter than only strips color - and one that strips most(?) + # - but does it ever really make sense to strip things like "esc(0" and "esc(B" which flip to the G0 G1 characters? (once stripped - things like box-lines become ordinary letters - unlikely to be desired?) + #punk::ansi::ansistrip converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion + #assumes line-buffering. a more advanced filter required if ansicodes can arrive split across separate read or write operations! + oo::class create ansistrip { + variable o_trecord + variable o_enc + variable o_encbuf + variable o_is_junction + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [::tcl::dict::get $tf -encoding] + set o_encbuf "" + if {[::tcl::dict::exists $tf -junction]} { + set o_is_junction [::tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize read write clear flush drain finalize] + } + method finalize {transform_handle} { + my destroy + } + method clear {transform_handle} { + return + } + method watch {transform_handle events} { + } + method drain {transform_handle} { + return "" + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + set outstring [punk::ansi::ansistrip $instring] + return [encoding convertto $o_enc $outstring] + } + method flush {transform_handle} { + return "" + } + #method write {transform_handle bytes} { + # #broken due to occasional unexpected byte sequence + # set instring [encoding convertfrom $o_enc $bytes] + # set outstring [punk::ansi::ansistrip $instring] + # return [encoding convertto $o_enc $outstring] + #} + method write {transform_handle bytes} { + #set instring [tcl::encoding::convertfrom $o_enc $bytes] ;naive approach will break due to unexpected byte sequence - occasionally + #bytes can break at arbitrary points making encoding conversions invalid. + + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + + set outstring [punk::ansi::ansistrip $stringdata] + return [tcl::encoding::convertto $o_enc $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + #a test + oo::class create reconvert { + variable o_trecord + variable o_enc + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + } + method initialize {transform_handle mode} { + return [list initialize read write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + } + oo::define reconvert { + method meta_is_redirection {} { + return 0 + } + } + + + #this isn't a particularly nice thing to do to a stream - especially if someone isn't expecting ansi codes sprinkled through it. + #It can be useful for test/debugging + #Due to chunking at random breaks - we have to check if an ansi code in the underlying stream has been split - otherwise our wrapping will break the existing ansi + # + set sixelstart_re {\x1bP([;0-9]*)q} ;#7-bit - todo 8bit + #todo kitty graphics \x1b_G... + #todo iterm graphics + + oo::class create ansiwrap { + variable o_trecord + variable o_enc + variable o_encbuf ;#buffering for partial encoding bytes + variable o_colour + variable o_do_colour + variable o_do_colourlist + variable o_do_normal + variable o_is_junction + variable o_codestack + variable o_gx_state ;#on/off alt graphics + variable o_buffered ;#buffering for partial ansi codes + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set settingsdict [tcl::dict::get $tf -settings] + if {[tcl::dict::exists $settingsdict -colour]} { + set o_colour [tcl::dict::get $settingsdict -colour] + #warning - we can't merge certain extended attributes such as undercurly into single SGR escape sequence + #while some terminals may handle these extended attributes even when merged - we need to cater for those that + #don't. Keeping them as a separate escape allows terminals that don't handle them to ignore just that code without + #affecting the interpretation of the other codes. + set o_do_colour [punk::ansi::a+ {*}$o_colour] + set o_do_colourlist [punk::ansi::ta::get_codes_single $o_do_colour] + set o_do_normal [punk::ansi::a] + } else { + set o_colour {} + set o_do_colour "" + set o_do_colourlist {} + set o_do_normal "" + } + set o_codestack [list] + set o_gx_state [expr {off}] + set o_encbuf "" + set o_buffered "" ;#hold back data that potentially contains partial ansi codes + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + + + #todo - track when in sixel,iterm,kitty graphics data - can be very large + method Trackcodes {chunk} { + #note - caller can use 2 resets in a single unit to temporarily reset to no sgr (override ansiwrap filter) + #e.g [a+ reset reset] (0;0m vs 0;m) + + #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]" + set buf $o_buffered$chunk + set emit "" + if {[string last \x1b $buf] >= 0} { + #detect will detect ansi SGR and gron groff and other codes + #REVIEW - ta::detect won't detect SOS without paired ST for things like PM + # ta::detectcode will - but then split_codes_single will treat unpaired SOS as text? + if {[punk::ansi::ta::detect $buf]} { + #split_codes_single regex faster than split_codes - but more resulting parts + #'single' refers to number of escapes - but can still contain e.g multiple SGR codes (or mode set operations etc) + set parts [punk::ansi::ta::split_codes_single $buf] + #process all pt/code pairs except for trailing pt + foreach {pt code} [lrange $parts 0 end-1] { + #puts "<==[ansistring VIEW -lf 1 $pt]==>" + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$pt + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$pt + } + } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # append emit $o_do_colour$pt$o_do_normal + # #append emit $pt + #} else { + # append emit $pt + #} + + set c1c2 [tcl::string::range $code 0 1] + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + ] $c1c2] 0 3] + switch -- $leadernorm { + 7CSI - 8CSI { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set o_codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set o_codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #todo - make caching is_sgr method + set dup_posns [lsearch -all -exact $o_codestack $code] + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $code + } else { + + } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set o_gx_state on + } + "B" { + set o_gx_state off + } + } + } + default { + #other ansi codes + } + } + append emit $code + } + + + set trailing_pt [lindex $parts end] + if {[string first \x1b $trailing_pt] >= 0} { + #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'" + #may not be plaintext after all + set o_buffered $trailing_pt + #puts stdout "=-=[ansistring VIEWCODES $o_buffered]" + } else { + #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a] + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$trailing_pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$trailing_pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$trailing_pt + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$trailing_pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$trailing_pt + } + } + #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { + # append emit $o_do_colour$trailing_pt$o_do_normal + #} else { + # append emit $trailing_pt + #} + #the previous o_buffered formed the data we emitted - nothing new to buffer because we emitted all parts including the trailing plaintext + set o_buffered "" + } + + + } else { + #REVIEW - this holding a buffer without emitting as we go is ugly. + # - we may do better to detect and retain the opener, then use that opener to avoid false splits within the sequence. + # - we'd then need to detect the appropriate close to restart splitting and codestacking + # - we may still need to retain and append the data to the opener (in some cases?) - which is a slight memory issue - but at least we would emit everything immediately. + + + #puts "-->esc but no detect" + #no complete ansi codes - but at least one esc is present + if {[string index $buf end] eq "\x1b" && [string first \x1b $buf] == [string length $buf]-1} { + #string index in first part of && clause to avoid some unneeded scans of whole string for this test + #we can't use 'string last' - as we need to know only esc is last char in buf + #puts ">>trailing-esc<<" + set o_buffered \x1b + set emit $o_do_colour[string range $buf 0 end-1]$o_do_normal + #set emit [string range $buf 0 end-1] + set buf "" + } else { + set emit_anyway 0 + #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer + if {[punk::ansi::ta::detect_st_open $buf]} { + #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms) + set st_partial_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code + #todo - configurable ST max - use 1k for now + if {$st_partial_len < 1001} { + append o_buffered $chunk + set emit "" + set buf "" + } else { + set emit_anyway 1 + set o_buffered "" + } + } else { + set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code + #most opening sequences are 1,2 or 3 chars - review? + set open_sequence_detected [punk::ansi::ta::detect_open $buf] + if {$possible_code_len > 10 && !$open_sequence_detected} { + set emit_anyway 1 + set o_buffered "" + } else { + #could be composite sequence with params - allow some reasonable max sequence length + #todo - configurable max sequence length + #len 40-50 quite possible for SGR sequence using coloured underlines etc, even without redundancies + # - allow some headroom for redundant codes when the caller didn't merge. + if {$possible_code_len < 101} { + append o_buffered $chunk + set buf "" + set emit "" + } else { + #allow a little more grace if we at least have an opening ansi sequence of any type.. + if {$open_sequence_detected && $possible_code_len < 151} { + append o_buffered $chunk + set buf "" + set emit "" + } else { + set emit_anyway 1 + set o_buffered "" + } + } + } + } + if {$emit_anyway} { + #assert: any time emit_anyway == 1 buf already contains all of previous o_buffered and o_buffered has been cleared. + + #looked ansi-like - but we've given enough length without detecting close.. + #treat as possible plain text with some esc or unrecognised ansi sequence + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # set emit $o_do_colour$buf$o_do_normal + #} else { + # set emit $buf + #} + } + } + } + } else { + #no esc + #puts stdout [a+ yellow]...[a] + #test! + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + set o_buffered "" + } + return [dict create emit $emit stacksize [llength $o_codestack]] + } + method initialize {transform_handle mode} { + #clear undesirable in terminal output channels (review) + return [list initialize write flush read drain finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method clear {transform_handle} { + #In the context of stderr/stdout - we probably don't want clear to run. + #Terminals might call it in the middle of a split ansi code - resulting in broken output. + #Leave clear of it the init call + puts stdout "" + set emit [tcl::encoding::convertto $o_enc $o_buffered] + set o_buffered "" + return $emit + } + method flush {transform_handle} { + #puts stdout "" + set inputbytes $o_buffered$o_encbuf + set emit [tcl::encoding::convertto $o_enc $inputbytes] + set o_buffered "" + set o_encbuf "" + return $emit + } + method write {transform_handle bytes} { + #set instring [tcl::encoding::convertfrom $o_enc $bytes] ;naive approach will break due to unexpected byte sequence - occasionally + #bytes can break at arbitrary points making encoding conversions invalid. + + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [string length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [string range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + set streaminfo [my Trackcodes $stringdata] + set emit [dict get $streaminfo emit] + + #review - wrapping already done in Trackcodes + #if {[dict get $streaminfo stacksize] == 0} { + # #no ansi on the stack - we can wrap + # #review + # set outstring "$o_do_colour$emit$o_do_normal" + #} else { + #} + #if {[llength $o_codestack]} { + # set outstring [punk::ansi::codetype::sgr_merge_singles $o_codestack]$emit + #} else { + # set outstring $emit + #} + #set outstring $emit + + #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<" + #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<" + return [tcl::encoding::convertto $o_enc $emit] + } + method Write_naive {transform_handle bytes} { + set instring [tcl::encoding::convertfrom $o_enc $bytes] + set outstring "$o_do_colour$instring$o_do_normal" + #set outstring ">>>$instring" + return [tcl::encoding::convertto $o_enc $outstring] + } + method drain {transform_handle} { + return "" + } + method read {transform_handle bytes} { + set instring [tcl::encoding::convertfrom $o_enc $bytes] + set outstring "$o_do_colour$instring$o_do_normal" + return [tcl::encoding::convertto $o_enc $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + #todo - something + oo::class create rebuffer { + variable o_trecord + variable o_enc + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + } + method initialize {transform_handle mode} { + return [list initialize read write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + #set outstring [string map [list \n ] $instring] + set outstring $instring + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define rebuffer { + method meta_is_redirection {} { + return 0 + } + } + + #has slight buffering/withholding of lone training cr - we can't be sure that a cr at end of chunk is part of \r\n sequence + oo::class create tounix { + variable o_trecord + variable o_enc + variable o_last_char_was_cr + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + set o_last_char_was_cr 0 + } + method initialize {transform_handle mode} { + return [list initialize write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #don't use read + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + #set outstring [string map [list \n ] $instring] + + if {$o_last_char_was_cr} { + set instring "\r$instring" + } + + set outstring [string map {\r\n \n} $instring] + set lastchar [string range $outstring end end] + if {$lastchar eq "\r"} { + set o_last_char_was_cr 1 + set outstring [string range $outstring 0 end-1] + } else { + set o_last_char_was_cr 0 + } + #review! can we detect eof here on the transform_handle? + #if eof, we don't want to strip a trailing \r + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define tounix { + method meta_is_redirection {} { + return $o_is_junction + } + } + #write to handle case where line-endings already \r\n too + oo::class create towindows { + variable o_trecord + variable o_enc + variable o_last_char_was_cr + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + set o_last_char_was_cr 0 + } + method initialize {transform_handle mode} { + return [list initialize write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #don't use read + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + #set outstring [string map [list \n ] $instring] + + if {$o_last_char_was_cr} { + set instring "\r$instring" + } + + set outstring [string map {\r\n \uFFFF} $instring] + set outstring [string map {\n \r\n} $outstring] + set outstring [string map {\uFFFF \r\n} $outstring] + + set lastchar [string range $outstring end end] + if {$lastchar eq "\r"} { + set o_last_char_was_cr 1 + set outstring [string range $outstring 0 end-1] + } else { + set o_last_char_was_cr 0 + } + #review! can we detect eof here on the transform_handle? + #if eof, we don't want to strip a trailing \r + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define towindows { + method meta_is_redirection {} { + return $o_is_junction + } + } + + } +} + +# ---------------------------------------------------------------------------- +#review float/sink metaphor. +#perhaps something with the concept of upstream and downstream? +#need concepts for push towards data, sit in middle where placed, and lag at tail of data stream. +## upstream for stdin is at the bottom of the stack and for stdout is the top of the stack. +#upstream,neutral-upstream,downstream,downstream-aside,downstream-replace (default neutral-upstream - require action 'stack' to use standard channel stacking concept and ignore other actions) +#This is is a bit different from the float/sink metaphor which refers to the channel stacking order as opposed to the data-flow direction. +#The idea would be that whether input or output +# upstream additions go to the side closest to the datasource +# downstream additions go furthest from the datasource +# - all new additions go ahead of any diversions as the most upstream diversion is the current end of the stream in a way. +# - this needs review regarding subsequent removal of the diversion and whether filters re-order in response.. +# or if downstream & neutral additions are reclassified upon insertion if they land among existing upstreams(?) +# neutral-upstream goes to the datasource side of the neutral-upstream list. +# No 'neutral' option provided so that we avoid the need to think forwards or backwards when adding stdin vs stdout shellfilter does the necessary pop/push reordering. +# No 'neutral-downstream' to reduce complexity. +# downstream-replace & downstream-aside head downstream to the first diversion they encounter. ie these actions are no longer referring to the stack direction but only the dataflow direction. +# +# ---------------------------------------------------------------------------- +# +# 'filters' are transforms that don't redirect +# - limited range of actions to reduce complexity. +# - any requirement not fulfilled by float,sink,sink-replace,sink-sideline should be done by multiple pops and pushes +# +#actions can float to top of filters or sink to bottom of filters +#when action is of type sink, it can optionally replace or sideline the first non-filter it encounters (highest redirection on the stack.. any lower are starved of the stream anyway) +# - sideline means to temporarily replace the item and keep a record, restoring if/when we are removed from the transform stack +# +##when action is of type float it can't replace or sideline anything. A float is added above any existing floats and they stay in the same order relative to each other, +#but non-floats added later will sit below all floats. +#(review - float/sink initially designed around output channels. For stdin the dataflow is reversed. implement float-aside etc?) +# +# +#action: float sink sink-replace,sink-sideline +# +# +## note - whether stack is for input or output we maintain it in the same direction - which is in sync with the tcl chan pop chan push concept. +## +namespace eval shellfilter::stack { + namespace export {[a-z]*} + namespace ensemble create + #todo - implement as oo ? + variable pipelines [list] + + proc items {} { + #review - stdin,stdout,stderr act as pre-existing pipelines, and we can't create a new one with these names - so they should probably be autoconfigured and listed.. + # - but in what contexts? only when we find them in [chan names]? + variable pipelines + return [dict keys $pipelines] + } + proc item {pipename} { + variable pipelines + return [dict get $pipelines $pipename] + } + proc item_tophandle {pipename} { + variable pipelines + set handle "" + if {[dict exists $pipelines $pipename stack]} { + set stack [dict get $pipelines $pipename stack] + set topstack [lindex $stack end] ;#last item in stack is top (for output channels anyway) review comment. input chans? + if {$topstack ne ""} { + if {[dict exists $topstack -handle]} { + set handle [dict get $topstack -handle] + } + } + } + return $handle + } + proc status {{pipename *} args} { + variable pipelines + set pipecount [dict size $pipelines] + set tabletitle "$pipecount pipelines active" + set t [textblock::class::table new $tabletitle] + $t add_column -headers [list channel-ident] + $t add_column -headers [list device-info localchan] + $t configure_column 1 -header_colspans {3} + $t add_column -headers [list "" remotechan] + $t add_column -headers [list "" tid] + $t add_column -headers [list stack-info] + foreach k [dict keys $pipelines $pipename] { + set lc [dict get $pipelines $k device localchan] + set rc [dict get $pipelines $k device remotechan] + if {[dict exists $k device workertid]} { + set tid [dict get $pipelines $k device workertid] + } else { + set tid "-" + } + set stack [dict get $pipelines $k stack] + if {![llength $stack]} { + set stackinfo "" + } else { + set tbl_inner [textblock::class::table new] + $tbl_inner configure -show_edge 0 + foreach rec $stack { + set handle [punk::lib::dict_getdef $rec -handle ""] + set id [punk::lib::dict_getdef $rec -id ""] + set transform [namespace tail [punk::lib::dict_getdef $rec -transform ""]] + set settings [punk::lib::dict_getdef $rec -settings ""] + $tbl_inner add_row [list $id $transform $handle $settings] + } + set stackinfo [$tbl_inner print] + $tbl_inner destroy + } + $t add_row [list $k $lc $rc $tid $stackinfo] + } + set result [$t print] + $t destroy + return $result + } + proc status1 {{pipename *} args} { + variable pipelines + + set pipecount [dict size $pipelines] + set tableprefix "$pipecount pipelines active\n" + foreach p [dict keys $pipelines] { + append tableprefix " " $p \n + } + package require overtype + #todo -verbose + set table "" + set ac1 [string repeat " " 15] + set ac2 [string repeat " " 42] + set ac3 [string repeat " " 70] + append table "[overtype::left $ac1 channel-ident] " + append table "[overtype::left $ac2 device-info] " + append table "[overtype::left $ac3 stack-info]" + append table \n + + + set bc1 [string repeat " " 5] ;#stack id + set bc2 [string repeat " " 25] ;#transform + set bc3 [string repeat " " 50] ;#settings + + foreach k [dict keys $pipelines $pipename] { + set lc [dict get $pipelines $k device localchan] + if {[dict exists $k device workertid]} { + set tid [dict get $pipelines $k device workertid] + } else { + set tid "" + } + + + set col1 [overtype::left $ac1 $k] + set col2 [overtype::left $ac2 "localchan: $lc tid:$tid"] + + set stack [dict get $pipelines $k stack] + if {![llength $stack]} { + set col3 $ac3 + } else { + set rec [lindex $stack 0] + set bcol1 [overtype::left $bc1 [dict get $rec -id]] + set bcol2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] + set bcol3 [overtype::left $bc3 [dict get $rec -settings]] + set stackrow "$bcol1 $bcol2 $bcol3" + set col3 [overtype::left $ac3 $stackrow] + } + + append table "$col1 $col2 $col3\n" + + + foreach rec [lrange $stack 1 end] { + set col1 $ac1 + set col2 $ac2 + if {[llength $rec]} { + set bc1 [overtype::left $bc1 [dict get $rec -id]] + set bc2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] + set bc3 [overtype::left $bc3 [dict get $rec -settings]] + set stackrow "$bc1 $bc2 $bc3" + set col3 [overtype::left $ac3 $stackrow] + } else { + set col3 $ac3 + } + append table "$col1 $col2 $col3\n" + } + + } + return $tableprefix$table + } + #used for output channels - we usually want to sink redirections below the floaters and down to topmost existing redir + proc _get_stack_floaters {stack} { + set floaters [list] + foreach t [lreverse $stack] { + switch -- [dict get $t -action] { + float { + lappend floaters $t + } + default { + break + } + } + } + return [lreverse $floaters] + } + + + + #for output-channel sinking + proc _get_stack_top_redirection {stack} { + set r 0 ;#reverse index + foreach t [lreverse $stack] { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index + return [list index $idx record $t] + } + incr r + } + #not found + return [list index -1 record {}] + } + #exclude float-locked, locked, sink-locked + proc _get_stack_top_redirection_replaceable {stack} { + set r 0 ;#reverse index + foreach t [lreverse $stack] { + set action [dict get $t -action] + if {![string match "*locked*" $action]} { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index + return [list index $idx record $t] + } + } + incr r + } + #not found + return [list index -1 record {}] + } + + + #for input-channels ? + proc _get_stack_bottom_redirection {stack} { + set i 0 + foreach t $stack { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + return [linst index $i record $t] + } + incr i + } + #not found + return [list index -1 record {}] + } + + + proc get_next_counter {pipename} { + variable pipelines + #use dictn incr ? + set counter [dict get $pipelines $pipename counter] + incr counter + dict set pipelines $pipename counter $counter + return $counter + } + + proc unwind {pipename} { + variable pipelines + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $pipelines $pipename device localchan] + foreach tf [lreverse $stack] { + chan pop $localchan + } + dict set pipelines $pipename [list] + } + #todo + proc delete {pipename {wait 0}} { + variable pipelines + set pipeinfo [dict get $pipelines $pipename] + set deviceinfo [dict get $pipeinfo device] + set localchan [dict get $deviceinfo localchan] + unwind $pipename + + #release associated thread + set tid [dict get $deviceinfo workertid] + if {$wait} { + thread::release -wait $tid + } else { + thread::release $tid + } + + #Memchan closes without error - tcl::chan::fifo2 raises something like 'can not find channel named "rc977"' - REVIEW. why? + catch {chan close $localchan} + } + #review - proc name clarity is questionable. remove_stackitem? + proc remove {pipename remove_id} { + variable pipelines + if {![dict exists $pipelines $pipename]} { + puts stderr "WARNING: shellfilter::stack::remove pipename '$pipename' not found in pipelines dict: '$pipelines' [info level -1]" + return + } + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $pipelines $pipename device localchan] + set posn 0 + set idposn -1 + set asideposn -1 + foreach t $stack { + set id [dict get $t -id] + if {$id eq $remove_id} { + set idposn $posn + break + } + #look into asides (only can be one for now) + if {[llength [dict get $t -aside]]} { + set a [dict get $t -aside] + if {[dict get $a -id] eq $remove_id} { + set asideposn $posn + break + } + } + incr posn + } + + if {$asideposn > 0} { + #id wasn't found directly in stack, but in an -aside. we don't need to pop anything - just clear this aside record + set container [lindex $stack $asideposn] + dict set container -aside {} + lset stack $asideposn $container + dict set pipelines $pipename stack $stack + } else { + if {$idposn < 0} { + ::shellfilter::log::write shellfilter "ERROR shellfilter::stack::remove $pipename id '$remove_id' not found" + puts stderr "|WARNING>shellfilter::stack::remove $pipename id '$remove_id' not found" + return 0 + } + set removed_item [lindex $stack $idposn] + + #include idposn in poplist + set poplist [lrange $stack $idposn end] + set stack [lreplace $stack $idposn end] + #pop all chans before adding anything back in! + foreach p $poplist { + chan pop $localchan + } + + if {[llength [dict get $removed_item -aside]]} { + set restore [dict get $removed_item -aside] + set t [dict get $restore -transform] + set tsettings [dict get $restore -settings] + set obj [$t new $restore] + set h [chan push $localchan $obj] + dict set restore -handle $h + dict set restore -obj $obj + lappend stack $restore + } + + #put popped back except for the first one, which we want to remove + foreach p [lrange $poplist 1 end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + dict set p -handle $h + dict set p -obj $obj + lappend stack $p + } + dict set pipelines $pipename stack $stack + } + #JMNJMN 2025 review! + #show_pipeline $pipename -note "after_remove $remove_id" + return 1 + } + + #pop a number of items of the top of the stack, add our transform record, and add back all (or the tail of poplist if pushstartindex > 0) + proc insert_transform {pipename stack transformrecord poplist {pushstartindex 0}} { + variable pipelines + set bottom_pop_posn [expr {[llength $stack] - [llength $poplist]}] + set poplist [lrange $stack $bottom_pop_posn end] + set stack [lreplace $stack $bottom_pop_posn end] + + set localchan [dict get $pipelines $pipename device localchan] + foreach p [lreverse $poplist] { + chan pop $localchan + } + set transformname [dict get $transformrecord -transform] + set transformsettings [dict get $transformrecord -settings] + set obj [$transformname new $transformrecord] + set h [chan push $localchan $obj] + dict set transformrecord -handle $h + dict set transformrecord -obj $obj + dict set transformrecord -note "insert_transform" + lappend stack $transformrecord + foreach p [lrange $poplist $pushstartindex end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + #retain previous -id - code that added it may have kept reference and not expecting it to change + dict set p -handle $h + dict set p -obj $obj + dict set p -note "re-added" + + lappend stack $p + } + return $stack + } + + #fifo2 + proc new {pipename args} { + variable pipelines + if {($pipename in [dict keys $pipelines]) || ($pipename in [chan names])} { + error "shellfilter::stack::new error: pipename '$pipename' already exists" + } + + set opts [dict merge {-settings {}} $args] + set defaultsettings [dict create -raw 1 -buffering line -direction out] + set targetsettings [dict merge $defaultsettings [dict get $opts -settings]] + + set direction [dict get $targetsettings -direction] + + #pipename is the source/facility-name ? + if {$direction eq "out"} { + set pipeinfo [shellfilter::pipe::open_out $pipename $targetsettings] + } else { + puts stderr "|jn> pipe::open_in $pipename $targetsettings" + set pipeinfo [shellfilter::pipe::open_in $pipename $targetsettings] + } + #open_out/open_in will configure buffering based on targetsettings + + set program_chan [dict get $pipeinfo localchan] + set worker_chan [dict get $pipeinfo remotechan] + set workertid [dict get $pipeinfo workertid] + + + set deviceinfo [dict create pipename $pipename localchan $program_chan remotechan $worker_chan workertid $workertid direction $direction] + dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] + + return $deviceinfo + } + #we 'add' rather than 'push' because transforms can float,sink and replace/sideline so they don't necessarily go to the top of the transform stack + proc add {pipename transformname args} { + variable pipelines + #chan names doesn't reflect available channels when transforms are in place + #e.g stdout may exist but show as something like file191f5b0dd80 + if {($pipename ni [dict keys $pipelines])} { + if {[catch {eof $pipename} is_eof]} { + error "shellfilter::stack::add no existing chan or pipename matching '$pipename' in channels:[chan names] or pipelines:$pipelines use stdin/stderr/stdout or shellfilter::stack::new " + } + } + set args [dict merge {-action "" -settings {}} $args] + set action [dict get $args -action] + set transformsettings [dict get $args -settings] + if {[string first "::" $transformname] < 0} { + set transformname ::shellfilter::chan::$transformname + } + if {![llength [info commands $transformname]]} { + error "shellfilter::stack::push unknown transform '$transformname'" + } + + + if {![dict exists $pipelines $pipename]} { + #pipename must be in chan names - existing device/chan + #record a -read and -write end even if the device is only being used as one or the other + set deviceinfo [dict create pipename $pipename localchan $pipename remotechan {}] + dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] + } else { + set deviceinfo [dict get $pipelines $pipename device] + } + + set id [get_next_counter $pipename] + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $deviceinfo localchan] + + #we redundantly store chan in each transform - makes debugging clearer + # -encoding similarly could be stored only at the pipeline level (or even queried directly each filter-read/write), + # but here it may help detect unexpected changes during lifetime of the stack and avoids the chance of callers incorrectly using the transform handle?) + # jn + set transform_record [list -id $id -chan $pipename -encoding [chan configure $localchan -encoding] -transform $transformname -aside {} {*}$args] + switch -glob -- $action { + float - float-locked { + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + lappend stack $transform_record + } + "" - locked { + set floaters [_get_stack_floaters $stack] + if {![llength $floaters]} { + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + lappend stack $transform_record + } else { + set poplist $floaters + set stack [insert_transform $pipename $stack $transform_record $poplist] + } + } + "sink*" { + set redirinfo [_get_stack_top_redirection $stack] + set idx_existing_redir [dict get $redirinfo index] + if {$idx_existing_redir == -1} { + #no existing redirection transform on the stack + #pop everything.. add this record as the first redirection on the stack + set poplist $stack + set stack [insert_transform $pipename $stack $transform_record $poplist] + } else { + switch -glob -- $action { + "sink-replace" { + #include that index in the poplist + set poplist [lrange $stack $idx_existing_redir end] + #pop all from idx_existing_redir to end, but put back 'lrange $poplist 1 end' + set stack [insert_transform $pipename $stack $transform_record $poplist 1] + } + "sink-aside*" { + set existing_redir_record [lindex $stack $idx_existing_redir] + if {[string match "*locked*" [dict get $existing_redir_record -action]]} { + set put_aside 0 + #we can't aside this one - sit above it instead. + set poplist [lrange $stack $idx_existing_redir+1 end] + set stack [lrange $stack 0 $idx_existing_redir] + } else { + set put_aside 1 + dict set transform_record -aside [lindex $stack $idx_existing_redir] + set poplist [lrange $stack $idx_existing_redir end] + set stack [lrange $stack 0 $idx_existing_redir-1] + } + foreach p $poplist { + chan pop $localchan + } + set transformname [dict get $transform_record -transform] + set transform_settings [dict get $transform_record -settings] + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + dict set transform_record -note "insert_transform-with-aside" + lappend stack $transform_record + #add back poplist *except* the one we transferred into -aside (if we were able) + foreach p [lrange $poplist $put_aside end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + #retain previous -id - code that added it may have kept reference and not expecting it to change + dict set p -handle $h + dict set p -obj $obj + dict set p -note "re-added-after-sink-aside" + lappend stack $p + } + } + default { + #plain "sink" + #we only sink to the topmost redirecting filter - which makes sense for an output channel + #For stdin.. this is more problematic as we're more likely to want to intercept the bottom most redirection. + #todo - review. Consider making default insert position for input channels to be at the source... and float/sink from there. + # - we don't currently know from the stack api if adding input vs output channel - so this needs work to make intuitive. + # consider splitting stack::add to stack::addinput stack::addoutput to split the different behaviour + set poplist [lrange $stack $idx_existing_redir+1 end] + set stack [insert_transform $pipename $stack $transform_record $poplist] + } + } + } + } + default { + error "shellfilter::stack::add unimplemented action '$action'" + } + } + + dict set pipelines $pipename stack $stack + #puts stdout "==" + #puts stdout "==>stack: $stack" + #puts stdout "==" + + #JMNJMN + #show_pipeline $pipename -note "after_add $transformname $args" + return $id + } + proc show_pipeline {pipename args} { + variable pipelines + set stack [dict get $pipelines $pipename stack] + set tag "SHELLFILTER::STACK" + #JMN - load from config + #::shellfilter::log::open $tag {-syslog 127.0.0.1:514} + if {[catch { + ::shellfilter::log::open $tag {-syslog ""} + } err]} { + #e.g safebase interp can't load required modules such as shellthread (or Thread) + puts stderr "shellfilter::show_pipeline cannot open log" + return + } + ::shellfilter::log::write $tag "transform stack for $pipename $args" + foreach tf $stack { + ::shellfilter::log::write $tag " $tf" + } + + } +} + + +namespace eval shellfilter { + variable sources [list] + variable stacks [dict create] + + proc ::shellfilter::redir_channel_to_log {chan args} { + variable sources + set default_logsettings [dict create \ + -tag redirected_$chan -syslog "" -file ""\ + ] + if {[dict exists $args -action]} { + set action [dict get $args -action] + } else { + # action "sink" is a somewhat reasonable default for an output redirection transform + # but it can make it harder to configure a plain ordered stack if the user is not expecting it, so we'll default to stack + # also.. for stdin transform sink makes less sense.. + #todo - default "stack" instead of empty string + set action "" + } + if {[dict exists $args -settings]} { + set logsettings [dict get $args -settings] + } else { + set logsettings {} + } + + set logsettings [dict merge $default_logsettings $logsettings] + set tag [dict get $logsettings -tag] + if {$tag ni $sources} { + lappend sources $tag + } + + set id [shellfilter::stack::add $chan logonly -action $action -settings $logsettings] + return $id + } + + proc ::shellfilter::redir_output_to_log {tagprefix args} { + variable sources + + set default_settings [list -tag ${tagprefix} -syslog "" -file ""] + + set opts [dict create -action "" -settings {}] + set opts [dict merge $opts $args] + set optsettings [dict get $opts -settings] + set settings [dict merge $default_settings $optsettings] + + set tag [dict get $settings -tag] + if {$tag ne $tagprefix} { + error "shellfilter::redir_output_to_log -tag value must match supplied tagprefix:'$tagprefix'. Omit -tag, or make it the same. It will automatically be suffixed with stderr and stdout. Use redir_channel_to_log if you want to separately configure each channel" + } + lappend sources ${tagprefix}stdout ${tagprefix}stderr + + set stdoutsettings $settings + dict set stdoutsettings -tag ${tagprefix}stdout + set stderrsettings $settings + dict set stderrsettings -tag ${tagprefix}stderr + + set idout [redir_channel_to_log stdout -action [dict get $opts -action] -settings $stdoutsettings] + set iderr [redir_channel_to_log stderr -action [dict get $opts -action] -settings $stderrsettings] + + return [list $idout $iderr] + } + + #eg try: set v [list #a b c] + #vs set v {#a b c} + proc list_is_canonical l { + #courtesy DKF via wiki https://wiki.tcl-lang.org/page/BNF+for+Tcl + if {[catch {llength $l}]} {return 0} + string equal $l [list {*}$l] + } + + #return a dict keyed on numerical list index showing info about each element + # - particularly + # 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list + # 'head_tail_chars' to show current first and last character (in case it's wrapped e.g in double or single quotes or an existing set of braces) + proc list_element_info {inputlist} { + set i 0 + set info [dict create] + set testlist [list] + foreach original_item $inputlist { + #--- + # avoid sharing internal rep with original items in the list (avoids shimmering of rep in original list for certain items such as paths) + unset -nocomplain item + append item $original_item {} + #--- + + set iteminfo [dict create] + set itemlen [string length $item] + lappend testlist $item + set tcl_len [string length $testlist] + set diff [expr {$tcl_len - $itemlen}] + if {$diff == 0} { + dict set iteminfo wouldbrace 0 + dict set iteminfo wouldescape 0 + } else { + #test for escaping vs bracing! + set testlistchars [split $testlist ""] + if {([lindex $testlistchars 0] eq "\{") && ([lindex $testlistchars end] eq "\}")} { + dict set iteminfo wouldbrace 1 + dict set iteminfo wouldescape 0 + } else { + dict set iteminfo wouldbrace 0 + dict set iteminfo wouldescape 1 + } + } + set testlist [list] + set charlist [split $item ""] + set char_a [lindex $charlist 0] + set char_b [lindex $charlist 1] + set char_ab ${char_a}${char_b} + set char_y [lindex $charlist end-1] + set char_z [lindex $charlist end] + set char_yz ${char_y}${char_z} + + if { ("{" in $charlist) || ("}" in $charlist) } { + dict set iteminfo has_braces 1 + set innerchars [lrange $charlist 1 end-1] + if {("{" in $innerchars) || ("}" in $innerchars)} { + dict set iteminfo has_inner_braces 1 + } else { + dict set iteminfo has_inner_braces 0 + } + } else { + dict set iteminfo has_braces 0 + dict set iteminfo has_inner_braces 0 + } + + #todo - brace/char counting to determine if actually 'wrapped' + #e.g we could have list element {((abc)} - which appears wrapped if only looking at first and last chars. + #also {(x) (y)} as a list member.. how to treat? + if {$itemlen <= 1} { + dict set iteminfo apparentwrap "not" + } else { + #todo - switch on $char_a$char_z + if {($char_a eq {"}) && ($char_z eq {"})} { + dict set iteminfo apparentwrap "doublequotes" + } elseif {($char_a eq "'") && ($char_z eq "'")} { + dict set iteminfo apparentwrap "singlequotes" + } elseif {($char_a eq "(") && ($char_z eq ")")} { + dict set iteminfo apparentwrap "brackets" + } elseif {($char_a eq "\{") && ($char_z eq "\}")} { + dict set iteminfo apparentwrap "braces" + } elseif {($char_a eq "^") && ($char_z eq "^")} { + dict set iteminfo apparentwrap "carets" + } elseif {($char_a eq "\[") && ($char_z eq "\]")} { + dict set iteminfo apparentwrap "squarebrackets" + } elseif {($char_a eq "`") && ($char_z eq "`")} { + dict set iteminfo apparentwrap "backquotes" + } elseif {($char_a eq "\n") && ($char_z eq "\n")} { + dict set iteminfo apparentwrap "lf-newline" + } elseif {($char_ab eq "\r\n") && ($char_yz eq "\r\n")} { + dict set iteminfo apparentwrap "crlf-newline" + } else { + dict set iteminfo apparentwrap "not-determined" + } + + } + dict set iteminfo wrapbalance "unknown" ;#a hint to caller that apparentwrap is only a guide. todo - possibly make wrapbalance indicate 0 for unbalanced.. and positive numbers for outer-count of wrappings. + #e.g {((x)} == 0 {((x))} == 1 {(x) (y (z))} == 2 + dict set iteminfo head_tail_chars [list $char_a $char_z] + set namemap [list \ + \r cr\ + \n lf\ + {"} doublequote\ + {'} singlequote\ + "`" backquote\ + "^" caret\ + \t tab\ + " " sp\ + "\[" lsquare\ + "\]" rsquare\ + "(" lbracket\ + ")" rbracket\ + "\{" lbrace\ + "\}" rbrace\ + \\ backslash\ + / forwardslash\ + ] + if {[string length $char_a]} { + set char_a_name [string map $namemap $char_a] + } else { + set char_a_name "emptystring" + } + if {[string length $char_z]} { + set char_z_name [string map $namemap $char_z] + } else { + set char_z_name "emptystring" + } + + dict set iteminfo head_tail_names [list $char_a_name $char_z_name] + dict set iteminfo len $itemlen + dict set iteminfo difflen $diff ;#2 for braces, 1 for quoting?, or 0. + dict set info $i $iteminfo + incr i + } + return $info + } + + + #parse bracketed expression (e.g produced by vim "shellxquote=(" ) into a tcl (nested) list + #e.g {(^c:/my spacey/path^ >^somewhere^)} + #e.g {(blah (etc))}" + #Result is always a list - even if only one toplevel set of brackets - so it may need [lindex $result 0] if input is the usual case of {( ...)} + # - because it also supports the perhaps less likely case of: {( ...) unbraced (...)} etc + # Note that + #maintenance warning - duplication in branches for bracketed vs unbracketed! + proc parse_cmd_brackets {str} { + #wordwrappers currently best suited to non-bracket entities - no bracket matching within - anything goes until end-token reached. + # - but.. they only take effect where a word can begin. so a[x y] may be split at the space unless it's within some other wraper e.g " a[x y]" will not break at the space + # todo - consider extending the in-word handling of word_bdepth which is currently only applied to () i.e aaa(x y) is supported but aaa[x y] is not as the space breaks the word up. + set wordwrappers [list \ + "\"" [list "\"" "\"" "\""]\ + {^} [list "\"" "\"" "^"]\ + "'" [list "'" "'" "'"]\ + "\{" [list "\{" "\}" "\}"]\ + {[} [list {[} {]} {]}]\ + ] ;#dict mapping start_character to {replacehead replacetail expectedtail} + set shell_specials [list "|" "|&" "<" "<@" "<<" ">" "2>" ">&" ">>" "2>>" ">>&" ">@" "2>@" "2>@1" ">&@" "&" "&&" ] ;#words/chars that may precede an opening bracket but don't merge with the bracket to form a word. + #puts "pb:$str" + set in_bracket 0 + set in_word 0 + set word "" + set result {} + set word_bdepth 0 + set word_bstack [list] + set wordwrap "" ;#only one active at a time + set bracketed_elements [dict create] + foreach char [split $str ""] { + #puts "c:$char bracketed:$bracketed_elements" + if {$in_bracket > 0} { + if {$in_word} { + if {[string length $wordwrap]} { + #anything goes until end-char + #todo - lookahead and only treat as closing if before a space or ")" ? + lassign [dict get $wordwrappers $wordwrap] _open closing endmark + if {$char eq $endmark} { + set wordwrap "" + append word $closing + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } else { + append word $char + } + } else { + if {$word_bdepth == 0} { + #can potentially close off a word - or start a new one if word-so-far is a shell-special + if {$word in $shell_specials} { + if {$char eq ")"} { + dict lappend bracketed_elements $in_bracket $word + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + set word "" + set in_word 0 + } elseif {[regexp {[\s]} $char]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + incr in_bracket + } else { + #at end of shell-specials is another point to look for word started by a wordwrapper char + #- expect common case of things like >^/my/path^ + if {$char in [dict keys $wordwrappers]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 1 ;#just for explicitness.. we're straight into the next word. + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + #something unusual.. keep going with word! + append word $char + } + } + } else { + + if {$char eq ")"} { + dict lappend bracketed_elements $in_bracket $word + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + set word "" + set in_word 0 + } elseif {[regexp {[\s]} $char]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + #ordinary word up-against and opening bracket - brackets are part of word. + incr word_bdepth + append word "(" + } else { + append word $char + } + } + } else { + #currently only () are used for word_bdepth - todo add all or some wordwrappers chars so that the word_bstack can have multiple active. + switch -- $char { + "(" { + incr word_bdepth + lappend word_bstack $char + append word $char + } + ")" { + incr word_bdepth -1 + set word_bstack [lrange $word_bstack 0 end-1] + append word $char + } + default { + #spaces and chars added to word as it's still in a bracketed section + append word $char + } + } + } + } + } else { + + if {$char eq "("} { + incr in_bracket + + } elseif {$char eq ")"} { + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + } elseif {[regexp {[\s]} $char]} { + # + } else { + #first char of word - look for word-wrappers + if {$char in [dict keys $wordwrappers]} { + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + set word $char + } + set in_word 1 + } + } + } else { + if {$in_word} { + if {[string length $wordwrap]} { + lassign [dict get $wordwrappers $wordwrap] _open closing endmark + if {$char eq $endmark} { + set wordwrap "" + append word $closing + lappend result $word + set word "" + set in_word 0 + } else { + append word $char + } + } else { + + if {$word_bdepth == 0} { + if {$word in $shell_specials} { + if {[regexp {[\s]} $char]} { + lappend result $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + lappend result $word + set word "" + set in_word 0 + incr in_bracket + } else { + #at end of shell-specials is another point to look for word started by a wordwrapper char + #- expect common case of things like >^/my/path^ + if {$char in [dict keys $wordwrappers]} { + lappend result $word + set word "" + set in_word 1 ;#just for explicitness.. we're straight into the next word. + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + #something unusual.. keep going with word! + append word $char + } + } + + } else { + if {[regexp {[\s)]} $char]} { + lappend result $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + incr word_bdepth + append word $char + } else { + append word $char + } + } + } else { + switch -- $char { + "(" { + incr word_bdepth + append word $char + } + ")" { + incr word_bdepth -1 + append word $char + } + default { + append word $char + } + } + } + } + } else { + if {[regexp {[\s]} $char]} { + #insig whitespace(?) + } elseif {$char eq "("} { + incr in_bracket + dict set bracketed_elements $in_bracket [list] + } elseif {$char eq ")"} { + error "unbalanced bracket - unable to proceed result so far: $result bracketed_elements:$bracketed_elements" + } else { + #first char of word - look for word-wrappers + if {$char in [dict keys $wordwrappers]} { + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + set word $char + } + set in_word 1 + } + } + } + #puts "----$bracketed_elements" + } + if {$in_bracket > 0} { + error "shellfilter::parse_cmd_brackets missing close bracket. input was '$str'" + } + if {[dict exists $bracketed_elements 0]} { + #lappend result [lindex [dict get $bracketed_elements 0] 0] + lappend result [dict get $bracketed_elements 0] + } + if {$in_word} { + lappend result $word + } + return $result + } + + #only double quote if argument not quoted with single or double quotes + proc dquote_if_not_quoted {a} { + set wrapchars [string cat [string range $a 0 0] [string range $a end end]] + switch -- $wrapchars { + {""} - {''} { + return $a + } + default { + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + } + } + + #proc dquote_if_not_bracketed/braced? + + #wrap in double quotes if not double-quoted + proc dquote_if_not_dquoted {a} { + set wrapchars [string cat [string range $a 0 0] [string range $a end end]] + switch -- $wrapchars { + {""} { + return $a + } + default { + #escape any inner quotes.. + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + } + } + proc dquote {a} { + #escape any inner quotes.. + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + proc get_scriptrun_from_cmdlist_dquote_if_not {cmdlist {shellcmdflag ""}} { + set scr [auto_execok "script"] + if {[string length $scr]} { + #set scriptrun "( $c1 [lrange $cmdlist 1 end] )" + set arg1 [lindex $cmdlist 0] + if {[string first " " $arg1]>0} { + set c1 [dquote_if_not_quoted $arg1] + #set c1 "\"$arg1\"" + } else { + set c1 $arg1 + } + + if {[string length $shellcmdflag]} { + set scriptrun "$shellcmdflag \$($c1 " + } else { + set scriptrun "\$($c1 " + } + #set scriptrun "$c1 " + foreach a [lrange $cmdlist 1 end] { + #set a [string map [list "/" "//"] $a] + #set a [string map [list "\"" "\\\""] $a] + if {[string first " " $a] > 0} { + append scriptrun [dquote_if_not_quoted $a] + } else { + append scriptrun $a + } + append scriptrun " " + } + set scriptrun [string trim $scriptrun] + append scriptrun ")" + #return [list $scr -q -e -c $scriptrun /dev/null] + return [list $scr -e -c $scriptrun /dev/null] + } else { + return $cmdlist + } + } + + proc ::shellfilter::trun {commandlist args} { + #jmn + } + + + # run a command (or tcl script) with tees applied to stdout/stderr/stdin (or whatever channels are being used) + # By the point run is called - any transforms should already be in place on the channels if they're needed. + # The tees will be inline with none,some or all of those transforms depending on how the stack was configured + # (upstream,downstream configured via -float,-sink etc) + proc ::shellfilter::run {commandlist args} { + #must be a list. If it was a shell commandline string. convert it elsewhere first. + + variable sources + set runtag "shellfilter-run" + #set tid [::shellfilter::log::open $runtag [list -syslog 127.0.0.1:514]] + set tid [::shellfilter::log::open $runtag [list -syslog ""]] + if {[catch {llength $commandlist} listlen]} { + set listlen "" + } + ::shellfilter::log::write $runtag " commandlist:'$commandlist' listlen:$listlen strlen:[string length $commandlist]" + + #flush stdout + #flush stderr + + #adding filters with sink-aside will temporarily disable the existing redirection + #All stderr/stdout from the shellcommand will now tee to the underlying stderr/stdout as well as the configured syslog + + set defaults [dict create \ + -teehandle command \ + -outchan stdout \ + -errchan stderr \ + -inchan stdin \ + -tclscript 0 \ + ] + set opts [dict merge $defaults $args] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set outchan [dict get $opts -outchan] + set errchan [dict get $opts -errchan] + set inchan [dict get $opts -inchan] + set teehandle [dict get $opts -teehandle] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set is_script [dict get $opts -tclscript] + dict unset opts -tclscript ;#don't pass it any further + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set teehandle_out ${teehandle}out ;#default commandout + set teehandle_err ${teehandle}err + set teehandle_in ${teehandle}in + + + #puts stdout "shellfilter initialising tee_to_pipe transforms for in/out/err" + + # sources should be added when stack::new called instead(?) + foreach source [list $teehandle_out $teehandle_err] { + if {$source ni $sources} { + lappend sources $source + } + } + set outdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_out device] + set outpipechan [dict get $outdeviceinfo localchan] + set errdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_err device] + set errpipechan [dict get $errdeviceinfo localchan] + + #set indeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_in device] + #set inpipechan [dict get $indeviceinfo localchan] + + #NOTE:These transforms are not necessarily at the top of each stack! + #The float/sink mechanism, along with whether existing transforms are diversionary decides where they sit. + set id_out [shellfilter::stack::add $outchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_out -pipechan $outpipechan]] + set id_err [shellfilter::stack::add $errchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_err -pipechan $errpipechan]] + + # need to use os level channel handle for stdin - try named pipes (or even sockets) instead of fifo2 for this + # If non os-level channel - the command can't be run with the redirection + # stderr/stdout can be run with non-os handles in the call - + # but then it does introduce issues with terminal-detection and behaviour for stdout at least + # + # input is also a tee - we never want to change the source at this point - just log/process a side-channel of it. + # + #set id_in [shellfilter::stack::add $inchan tee_to_pipe -action sink-aside -settings [list -tag commandin -pipechan $inpipechan]] + + + #set id_out [shellfilter::stack::add stdout tee_to_log -action sink-aside -settings [list -tag shellstdout -syslog 127.0.0.1:514 -file ""]] + #set id_err [shellfilter::stack::add stderr tee_to_log -action sink-aside -settings [list -tag shellstderr -syslog 127.0.0.1:514 -file "stderr.txt"]] + + #we need to catch errors - and ensure stack::remove calls occur. + #An error can be raised if the command couldn't even launch, as opposed to a non-zero exitcode and stderr output from the command itself. + # + if {!$is_script} { + set experiment 0 + if {$experiment} { + try { + set results [exec {*}$commandlist] + set exitinfo [list exitcode 0] + } trap CHILDSTATUS {results options} { + set exitcode [lindex [dict get $options -errorcode] 2] + set exitinfo [list exitcode $exitcode] + } + } else { + if {[catch { + #run process with stdout/stderr/stdin or with configured channels + #set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan $inpipechan {*}$opts] + set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan stdin {*}$opts] + #puts stderr "---->exitinfo $exitinfo" + + #subprocess result should usually have an "exitcode" key + #but for background execution we will get a "pids" key of process ids. + } errMsg]} { + set exitinfo [list error "$errMsg" source shellcommand_stdout_stderr] + } + } + } else { + if {[catch { + #script result + set exitinfo [list result [uplevel #0 [list eval $commandlist]]] + } errMsg]} { + set exitinfo [list error "$errMsg" errorCode $::errorCode errorInfo "$::errorInfo"] + } + } + + + #the previous redirections on the underlying inchan/outchan/errchan items will be restored from the -aside setting during removal + #Remove execution-time Tees from stack + shellfilter::stack::remove stdout $id_out + shellfilter::stack::remove stderr $id_err + #shellfilter::stack::remove stderr $id_in + + + #chan configure stderr -buffering line + #flush stdout + + + ::shellfilter::log::write $runtag " return '$exitinfo'" + ::shellfilter::log::close $runtag + return $exitinfo + } + proc ::shellfilter::logtidyup { {tags {}} } { + variable sources + set worker_errorlist [list] + set tidied_sources [list] + set tidytag "logtidy" + + + # opening a thread or writing to a log/syslog close to possible process exit is probably not a great idea. + # we should ensure the thread already exists early on if we really need logging here. + # + #set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}] + #::shellfilter::log::write $tidytag " logtidyuptags '$tags'" + + foreach s $sources { + if {$s eq $tidytag} { + continue + } + #puts "logtidyup source $s" + set close 1 + if {[llength $tags]} { + if {$s ni $tags} { + set close 0 + } + } + if {$close} { + lappend tidied_sources $s + shellfilter::log::close $s + lappend worker_errorlist {*}[shellthread::manager::get_and_clear_errors $s] + } + } + set remaining_sources [list] + foreach s $sources { + if {$s ni $tidied_sources} { + lappend remaining_sources $s + } + } + + #set sources [concat $remaining_sources $tidytag] + set sources $remaining_sources + + #shellfilter::stack::unwind stdout + #shellfilter::stack::unwind stderr + return [list tidied $tidied_sources errors $worker_errorlist] + } + + #package require tcl::chan::null + # e.g set errchan [tcl::chan::null] + # e.g chan push stdout [shellfilter::chan::var new ::some_var] + proc ::shellfilter::shellcommand_stdout_stderr {commandlist outchan errchan inchan args} { + set valid_flags [list \ + -timeout \ + -outprefix \ + -errprefix \ + -debug \ + -copytempfile \ + -outbuffering \ + -errbuffering \ + -inbuffering \ + -readprocesstranslation \ + -outtranslation \ + -stdinhandler \ + -outchan \ + -errchan \ + -inchan \ + -teehandle\ + ] + + set runtag shellfilter-run2 + #JMN - load from config + #set tid [::shellfilter::log::open $runtag [list -syslog "127.0.0.1:514"]] + set tid [::shellfilter::log::open $runtag [list -syslog ""]] + + if {[llength $args] % 2} { + error "Trailing arguments after any positional arguments must be in pairs of the form -argname argvalue. Valid flags are:'$valid_flags'" + } + set invalid_flags [list] + foreach {k -} $args { + switch -- $k { + -timeout - + -outprefix - + -errprefix - + -debug - + -copytempfile - + -outbuffering - + -errbuffering - + -inbuffering - + -readprocesstranslation - + -outtranslation - + -stdinhandler - + -outchan - + -errchan - + -inchan - + -teehandle { + } + default { + lappend invalid_flags $k + } + } + } + if {[llength $invalid_flags]} { + error "Unknown option(s)'$invalid_flags': must be one of '$valid_flags'" + } + #line buffering generally best for output channels.. keeps relative output order of stdout/stdin closer to source order + #there may be data where line buffering is inappropriate, so it's configurable per std channel + #reading inputs with line buffering can result in extraneous newlines as we can't detect trailing data with no newline before eof. + set defaults [dict create \ + -outchan stdout \ + -errchan stderr \ + -inchan stdin \ + -outbuffering none \ + -errbuffering none \ + -readprocesstranslation auto \ + -outtranslation lf \ + -inbuffering none \ + -timeout 900000\ + -outprefix ""\ + -errprefix ""\ + -debug 0\ + -copytempfile 0\ + -stdinhandler ""\ + ] + + + + set args [dict merge $defaults $args] + set outbuffering [dict get $args -outbuffering] + set errbuffering [dict get $args -errbuffering] + set inbuffering [dict get $args -inbuffering] + set readprocesstranslation [dict get $args -readprocesstranslation] + set outtranslation [dict get $args -outtranslation] + set timeout [dict get $args -timeout] + set outprefix [dict get $args -outprefix] + set errprefix [dict get $args -errprefix] + set debug [dict get $args -debug] + set copytempfile [dict get $args -copytempfile] + set stdinhandler [dict get $args -stdinhandler] + + set debugname "shellfilter-debug" + + if {$debug} { + set tid [::shellfilter::log::open $debugname [list -syslog "127.0.0.1:514"]] + ::shellfilter::log::write $debugname " commandlist '$commandlist'" + } + #'clock micros' good enough id for shellcommand calls unless one day they can somehow be called concurrently or sequentially within a microsecond and within the same interp. + # a simple counter would probably work too + #consider other options if an alternative to the single vwait in this function is used. + set call_id [tcl::clock::microseconds] ; + set ::shellfilter::shellcommandvars($call_id,exitcode) "" + set ::shellfilter::shellcommandvars($call_id,timeoutid) "" + set waitvar ::shellfilter::shellcommandvars($call_id,waitvar) + if {$debug} { + ::shellfilter::log::write $debugname " waitvar '$waitvar'" + } + lassign [chan pipe] rderr wrerr + chan configure $wrerr -blocking 0 + + set custom_stderr "" + set lastitem [lindex $commandlist end] + #todo - ensure we can handle 2> file (space after >) + + #review - reconsider the handling of redirections such that tcl-style are handled totally separately to other shell syntaxes! + # + #note 2>@1 must ocur as last word for tcl - but 2@stdout can occur elsewhere + #(2>@stdout echoes to main stdout - not into pipeline) + #To properly do pipelines it looks like we will have to split on | and call this proc multiple times and wire it up accordingly (presumably in separate threads) + + switch -- [string trim $lastitem] { + {&} { + set name [lindex $commandlist 0] + #background execution - stdout and stderr from child still comes here - but process is backgrounded + #FIX! - this is broken for paths with backslashes for example + #set pidlist [exec {*}[concat $name [lrange $commandlist 1 end]]] + set pidlist [exec {*}$commandlist] + return [list pids $pidlist] + } + {2>&1} - {2>@1} { + set custom_stderr {2>@1} ;#use the tcl style + set commandlist [lrange $commandlist 0 end-1] + } + default { + # 2> filename + # 2>> filename + # 2>@ openfileid + set redir2test [string range $lastitem 0 1] + if {$redir2test eq "2>"} { + set custom_stderr $lastitem + set commandlist [lrange $commandlist 0 end-1] + } + } + } + set lastitem [lindex $commandlist end] + + set teefile "" ;#empty string, write, append + #an ugly hack.. because redirections seem to arrive wrapped - review! + #There be dragons here.. + #Be very careful with list manipulation of the commandlist string.. backslashes cause havoc. commandlist must always be a well-formed list. generally avoid string manipulations on entire list or accidentally breaking a list element into parts if it shouldn't be.. + #The problem here - is that we can't always know what was intended on the commandline regarding quoting + + ::shellfilter::log::write $runtag "checking for redirections in $commandlist" + #sometimes we see a redirection without a following space e.g >C:/somewhere + #normalize + switch -regexp -- $lastitem\ + {^>[/[:alpha:]]+} { + set lastitem "> [string range $lastitem 1 end]" + }\ + {^>>[/[:alpha:]]+} { + set lastitem ">> [string range $lastitem 2 end]" + } + + + #for a redirection, we assume either a 2-element list at tail of form {> {some path maybe with spaces}} + #or that the tail redirection is not wrapped.. x y z > {some path maybe with spaces} + #we can't use list methods such as llenth on a member of commandlist + set wordlike_parts [regexp -inline -all {\S+} $lastitem] + + if {([llength $wordlike_parts] >= 2) && ([lindex $wordlike_parts 0] in [list ">>" ">"])} { + #wrapped redirection - but maybe not 'well' wrapped (unquoted filename) + set lastitem [string trim $lastitem] ;#we often see { > something} + + #don't use lassign or lrange on the element itself without checking first + #we can treat the commandlist as a whole as a well formed list but not neccessarily each element within. + #lassign $lastitem redir redirtarget + #set commandlist [lrange $commandlist 0 end-1] + # + set itemchars [split $lastitem ""] + set firstchar [lindex $itemchars 0] + set lastchar [lindex $itemchars end] + + #NAIVE test for double quoted only! + #consider for example {"a" x="b"} + #testing first and last is not decisive + #We need to decide what level of drilling down is even appropriate here.. + #if something was double wrapped - it was perhaps deliberate so we don't interpret it as something(?) + set head_tail_chars [list $firstchar $lastchar] + set doublequoted [expr {[llength [lsearch -all $head_tail_chars "\""]] == 2}] + if {[string equal "\{" $firstchar] && [string equal "\}" $lastchar]} { + set curlyquoted 1 + } else { + set curlyquoted 0 + } + + if {$curlyquoted} { + #these are not the tcl protection brackets but ones supplied in the argument + #it's still not valid to use list operations on a member of the commandlist + set inner [string range $lastitem 1 end-1] + #todo - fix! we still must assume there could be list-breaking data! + set innerwords [regexp -inline -all {\S+} $inner] ;#better than [split $inner] because we don't get extra empty elements for each whitespace char + set redir [lindex $innerwords 0] ;#a *potential* redir - to be tested below + set redirtarget [lrange $innerwords 1 end] ;#all the rest + } elseif {$doublequoted} { + ::shellfilter::log::write $debugname "doublequoting at tail of command '$commandlist'" + set inner [string range $lastitem 1 end-1] + set innerwords [regexp -inline -all {\S+} $inner] + set redir [lindex $innerwords 0] + set redirtarget [lrange $innerwords 1 end] + } else { + set itemwords [regexp -inline -all {\S+} $lastitem] + # e.g > c:\test becomes > {c:\test} + # but > c/mnt/c/test/temp.txt stays as > /mnt/c/test/temp.txt + set redir [lindex $itemwords 0] + set redirtarget [lrange $itemwords 1 end] + } + set commandlist [lrange $commandlist 0 end-1] + + } elseif {[lindex $commandlist end-1] in [list ">>" ">"]} { + #unwrapped redirection + #we should be able to use list operations like lindex and lrange here as the command itself is hopefully still a well formed list + set redir [lindex $commandlist end-1] + set redirtarget [lindex $commandlist end] + set commandlist [lrange $commandlist 0 end-2] + } else { + #no redirection + set redir "" + set redirtarget "" + #no change to command list + } + + + switch -- $redir { + ">>" - ">" { + set redirtarget [string trim $redirtarget "\""] + ::shellfilter::log::write $runtag " have redirection '$redir' to '$redirtarget'" + + set winfile $redirtarget ;#default assumption + switch -glob -- $redirtarget { + "/c/*" { + set winfile "c:/[string range $redirtarget 3 end]" + } + "/mnt/c/*" { + set winfile "c:/[string range $redirtarget 7 end]" + } + } + + if {[file exists [file dirname $winfile]]} { + #containing folder for target exists + if {$redir eq ">"} { + set teefile "write" + } else { + set teefile "append" + } + ::shellfilter::log::write $runtag "Directory exists '[file dirname $winfile]' operation:$teefile" + } else { + #we should be writing to a file.. but can't + ::shellfilter::log::write $runtag "cannot verify directory exists '[file dirname $winfile]'" + } + } + default { + ::shellfilter::log::write $runtag "No redir found!!" + } + } + + #often first element of command list is wrapped and cannot be run directly + #e.g {{ls -l} {> {temp.tmp}}} + #we will assume that if there is a single element which is a pathname containing a space - it is doubly wrapped. + # this may not be true - and the command may fail if it's just {c:\program files\etc} but it is the less common case and we currently have no way to detect. + #unwrap first element.. will not affect if not wrapped anyway (subject to comment above re spaces) + set commandlist [concat [lindex $commandlist 0] [lrange $commandlist 1 end]] + + #todo? + #child process environment. + # - to pass a different environment to the child - we would need to save the env array, modify as required, and then restore the env array. + + #to restore buffering states after run + set remember_in_out_err_buffering [list \ + [chan configure $inchan -buffering] \ + [chan configure $outchan -buffering] \ + [chan configure $errchan -buffering] \ + ] + + set remember_in_out_err_translation [list \ + [chan configure $inchan -translation] \ + [chan configure $outchan -translation] \ + [chan configure $errchan -translation] \ + ] + + + + + #chan configure $inchan -buffering none -blocking 1 ;#test + chan configure $inchan -buffering $inbuffering -blocking 0 ;#we are setting up a readable handler for this - so non-blocking ok + + + chan configure $errchan -buffering $errbuffering + #chan configure $outchan -blocking 0 + chan configure $outchan -buffering $outbuffering ;#don't configure non-blocking. weird duplicate of *second* line occurs if you do. + # + + #-------------------------------------------- + #Tested on windows. Works to stop in output when buffering is none, reading from channel with -translation auto + #cmd, pwsh, tcl + #chan configure $outchan -translation lf + #chan configure $errchan -translation lf + #-------------------------------------------- + chan configure $outchan -translation $outtranslation + chan configure $errchan -translation $outtranslation + + #puts stderr "chan configure $wrerr [chan configure $wrerr]" + if {$debug} { + ::shellfilter::log::write $debugname "COMMAND [list $commandlist] strlen:[string length $commandlist] llen:[llength $commandlist]" + } + #todo - handle custom redirection of stderr to a file? + if {[string length $custom_stderr]} { + #::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist $custom_stderr] a+" + #set rdout [open |[concat $commandlist $custom_stderr] a+] + ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list $custom_stderr <@$inchan]] [list RDONLY]" + set rdout [open |[concat $commandlist [list <@$inchan $custom_stderr]] [list RDONLY]] + set rderr "bogus" ;#so we don't wait for it + } else { + ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]" + #set rdout [open |[concat $commandlist [list 2>@$wrerr]] a+] + #set rdout [open |[concat $commandlist [list 2>@$wrerr]] [list RDWR]] + + # If we don't redirect stderr to our own tcl-based channel - then the transforms don't get applied. + # This is the whole reason we need these file-event loops. + # Ideally we need something like exec,open in tcl that interacts with transformed channels directly and emits as it runs, not only at termination + # - and that at least appears like a terminal to the called command. + #set rdout [open |[concat $commandlist [list 2>@stderr <@$inchan]] [list RDONLY]] + + #REVIEW! + #if the child process takes a while to begin reading stdin - the data on stdin between when we stopped the parent chan event handler and when the child gets data, + #seems to stay buffered somewhere. It is then read by the parent, after the child returns. (ie not lost, but out-of-order) + #This can be apparent sometimes even with fast typing upon calling an executable. (e.g occasionally even vim - but seems to be timing based so might only happen first time if at all) + # see scriptlib/stdin_race.tcl etc test files. + #similar problem with python & perl - issue seems to be in libc or OS buffering behaviour for standard channels. + #note that zig (repo/jn/zig/stdin_race) seems to avoid this issue - todo - make zig based binary extension for open/exec? + + set rdout [open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]] + + chan configure $rderr -buffering $errbuffering -blocking 0 + chan configure $rderr -translation $readprocesstranslation + } + + + + set command_pids [pid $rdout] + #puts stderr "command_pids: $command_pids" + #tcl::process ensemble only available in 8.7+ - and it didn't prove useful here anyway + # the child process generally won't shut down until channels are closed. + # premature EOF on grandchild process launch seems to be due to lack of terminal emulation when redirecting stdin/stdout. + # worked around in punk/repl using 'script' command as a fake tty. + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $command_pids 0] ni $subprocesses} { + # puts stderr "pid [lindex $command_pids 0] not running $errMsg" + #} else { + # puts stderr "pid [lindex $command_pids 0] is running" + #} + + + if {$debug} { + ::shellfilter::log::write $debugname "pipeline pids: $command_pids" + } + + #jjj + + + chan configure $rdout -buffering $outbuffering -blocking 0 + chan configure $rdout -translation $readprocesstranslation + + if {![string length $custom_stderr]} { + chan event $rderr readable [list apply {{chan other wrerr outchan errchan waitfor errprefix errbuffering debug debugname pids} { + if {$errbuffering eq "line"} { + set countchunk [chan gets $chan chunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + #errprefix only applicable to line buffered output + if {$countchunk >= 0} { + if {[chan eof $chan]} { + puts -nonewline $errchan ${errprefix}$chunk + } else { + puts $errchan "${errprefix}$chunk" + } + } + } else { + set chunk [chan read $chan] + if {[string length $chunk]} { + puts -nonewline $errchan $chunk + } + } + if {[chan eof $chan]} { + flush $errchan ;#jmn + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $pids 0] ni $subprocesses} { + # puts stderr "stderr reader: pid [lindex $pids 0] no longer running" + #} else { + # puts stderr "stderr reader: pid [lindex $pids 0] still running" + #} + chan close $chan + #catch {chan close $wrerr} + #if {$other ni [chan names]} { + # set $waitfor stderr + #} + if {[catch {chan configure $other}]} { + set $waitfor stderr + } + } + }} $rderr $rdout $wrerr $outchan $errchan $waitvar $errprefix $errbuffering $debug $debugname $command_pids] + } + + #todo - handle case where large amount of stdin coming in faster than rdout can handle + #as is - arbitrary amount of memory could be used because we aren't using a filevent for rdout being writable + # - we're just pumping it in to the non-blocking rdout buffers + # ie there is no backpressure and stdin will suck in as fast as possible. + # for most commandlines this probably isn't too big a deal.. but it could be a problem for multi-GB disk images etc + # + # + + ## Note - detecting trailing missing nl before eof is basically the same here as when reading rdout from executable + # - but there is a slight difference in that with rdout we get an extra blocked state just prior to the final read. + # Not known if that is significant + ## with inchan configured -buffering line + #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl -r cat + #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl -r cat + #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:1 pend:-1 count:3 + #etc + + if 0 { + chan event $inchan readable [list apply {{chan wrchan inbuffering waitfor} { + #chan copy stdin $chan ;#doesn't work in a chan event + if {$inbuffering eq "line"} { + set countchunk [chan gets $chan chunk] + #puts $wrchan "stdinstate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + if {$countchunk >= 0} { + if {[chan eof $chan]} { + puts -nonewline $wrchan $chunk + } else { + puts $wrchan $chunk + } + } + } else { + set chunk [chan read $chan] + if {[string length $chunk]} { + puts -nonewline $wrchan $chunk + } + } + if {[chan eof $chan]} { + puts stderr "|stdin_reader>eof [chan configure stdin]" + chan event $chan readable {} + #chan close $chan + chan close $wrchan write ;#half close + #set $waitfor "stdin" + } + }} $inchan $rdout $inbuffering $waitvar] + + if {[string length $stdinhandler]} { + chan configure stdin -buffering line -blocking 0 + chan event stdin readable $stdinhandler + } + } + + set actual_proc_out_buffering [chan configure $rdout -buffering] + set actual_outchan_buffering [chan configure $outchan -buffering] + #despite whatever is configured - we match our reading to how we need to output + set read_proc_out_buffering $actual_outchan_buffering + + + + if {[string length $teefile]} { + set logname "redir_[string map {: _} $winfile]_[tcl::clock::microseconds]" + set tid [::shellfilter::log::open $logname {-syslog 127.0.0.1:514}] + if {$teefile eq "write"} { + ::shellfilter::log::write $logname "opening '$winfile' for write" + set fd [open $winfile w] + } else { + ::shellfilter::log::write $logname "opening '$winfile' for appending" + set fd [open $winfile a] + } + #chan configure $fd -translation lf + chan configure $fd -translation $outtranslation + chan configure $fd -encoding utf-8 + + set tempvar_bytetotal [namespace current]::totalbytes[tcl::clock::microseconds] + set $tempvar_bytetotal 0 + chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname writefile writefilefd copytempfile bytevar logtag} { + #review - if we write outprefix to normal stdout.. why not to redirected file? + #usefulness of outprefix is dubious + upvar $bytevar totalbytes + if {$read_proc_out_buffering eq "line"} { + #set outchunk [chan read $chan] + set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + if {$countchunk >= 0} { + if {![chan eof $chan]} { + set numbytes [expr {[string length $outchunk] + 1}] ;#we are assuming \n not \r\n - but count won't/can't be completely accurate(?) - review + puts $writefilefd $outchunk + } else { + set numbytes [string length $outchunk] + puts -nonewline $writefilefd $outchunk + } + incr totalbytes $numbytes + ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" + #puts $outchan "${outprefix} wrote $numbytes bytes to $writefile" + } + } else { + set outchunk [chan read $chan] + if {[string length $outchunk]} { + puts -nonewline $writefilefd $outchunk + set numbytes [string length $outchunk] + incr totalbytes $numbytes + ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" + } + } + if {[chan eof $chan]} { + flush $writefilefd ;#jmn + #set blocking so we can get exit code + chan configure $chan -blocking 1 + catch {::shellfilter::log::write $logtag "${outprefix} total bytes $totalbytes written to $writefile"} + #puts $outchan "${outprefix} total bytes $totalbytes written to $writefile" + catch {close $writefilefd} + if {$copytempfile} { + catch {file copy $writefile "[file rootname $writefile]_copy[file extension $writefile]"} + } + try { + chan close $chan + set ::shellfilter::shellcommandvars($call_id,exitcode) 0 + if {$debug} { + ::shellfilter::log::write $debugname "(teefile) -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + if {$debug} { + ::shellfilter::log::write $debugname "(teefile) CHILD PROCESS EXITED with code: $code" + } + set ::shellfilter::shellcommandvars($call_id,exitcode) $code + } + catch {chan close $wrerr} + #if {$other ni [chan names]} { + # set $waitfor stdout + #} + if {[catch {chan configure $other}]} { + set $waitfor stdout + } + } + }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $winfile $fd $copytempfile $tempvar_bytetotal $logname] + + } else { + + # This occurs when we have outbuffering set to 'line' - as the 'input' from rdout which comes from the executable is also configured to 'line' + # where b:0|1 is whether chan blocked $chan returns 0 or 1 + # pend is the result of chan pending $chan + # eof is the resot of chan eof $chan + + + ##------------------------- + ##If we still read with gets,to retrieve line by line for output to line-buffered output - but the input channel is configured with -buffering none + ## then we can detect the difference + # there is an extra blocking read - but we can stil use eof with data to detect the absent newline and avoid passing an extra one on. + #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /u/c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:1 eof:0 pend:-1 count:-1 + #instate b:0 eof:1 pend:-1 count:3 + #etc + ##------------------------ + + + #this should only occur if upstream is coming from stdin reader that has line buffering and hasn't handled the difference properly.. + ###reading with gets from line buffered input with trailing newline + #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + ###reading with gets from line buffered input with trailing newline + ##No detectable difference! + #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + ##------------------------- + + #Note that reading from -buffering none and writing straight out gives no problem because we pass the newlines through as is + + + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($rdout) 0 ;#a very specific case of readblocked prior to eof.. possibly not important + #this detection is disabled for now - but left for debugging in case it means something.. or changes + chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname pids} { + #set outchunk [chan read $chan] + + if {$read_proc_out_buffering eq "line"} { + set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + #countchunk can be -1 before eof e.g when blocked + #debugging output inline with data - don't leave enabled + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + if {$countchunk >= 0} { + if {![chan eof $chan]} { + puts $outchan ${outprefix}$outchunk + } else { + puts -nonewline $outchan ${outprefix}$outchunk + #if {$::shellfilter::chan::lastreadblocked_nodata_noeof($chan)} { + # seems to be the usual case + #} else { + # #false alarm, or ? we've reached eof with data but didn't get an empty blocking read just prior + # #Not known if this occurs + # #debugging output inline with data - don't leave enabled + # puts $outchan "!!!prev read didn't block: instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + #} + } + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) 0 + } else { + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) [expr {[chan blocked $chan] && ![chan eof $chan]}] + } + } else { + #puts $outchan "read CHANNEL $chan [chan configure $chan]" + #puts $outchan "write CHANNEL $outchan b:[chan configure $outchan -buffering] t:[chan configure $outchan -translation] e:[chan configure $outchan -encoding]" + set outchunk [chan read $chan] + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:[string length $outchunk]" + if {[string length $outchunk]} { + #set stringrep [encoding convertfrom utf-8 $outchunk] + #set newbytes [encoding convertto utf-16 $stringrep] + #puts -nonewline $outchan $newbytes + puts -nonewline $outchan $outchunk + } + } + + if {[chan eof $chan]} { + flush $outchan ;#jmn + #for now just look for first element in the pid list.. + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $pids 0] ni $subprocesses} { + # puts stderr "stdout reader pid: [lindex $pids 0] no longer running" + #} else { + # puts stderr "stdout reader pid: [lindex $pids 0] still running" + #} + + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan]" + chan configure $chan -blocking 1 ;#so we can get exit code + try { + chan close $chan + set ::shellfilter::shellcommandvars($call_id,exitcode) 0 + if {$debug} { + ::shellfilter::log::write $debugname " -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + set ::shellfilter::shellcommandvars($call_id,exitcode) $code + if {$debug} { + ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with code: $code" + } + } trap CHILDKILLED {result options} { + #set code [lindex [dict get $options -errorcode] 2] + #set ::shellfilter::shellcommandvars(%id%,exitcode) $code + set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled" + if {$debug} { + ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with result:'$result' options:'$options'" + } + + } finally { + #puts stdout "HERE" + #flush stdout + + } + catch {chan close $wrerr} + #if {$other ni [chan names]} { + # set $waitfor stdout + #} + if {[catch {chan configure $other}]} { + set $waitfor stdout + } + + } + }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $command_pids] + } + + #todo - add ability to detect activity/data-flow and change timeout to only apply for period with zero data + #e.g x hrs with no data(?) + #reset timeout when data detected. + #review - stdin??? + set ::shellfilter::shellcommandvars($call_id,timeoutid) [after $timeout [string map [list %cpids% $command_pids %w% $waitvar %id% $call_id %wrerr% $wrerr %rdout% $rdout %rderr% $rderr %debug% $debug %debugname% $debugname] { + if {[info exists ::shellfilter::shellcommandvars(%id%,exitcode)]} { + #killing the task (on windows) doesn't seem to work if done after we close the output channels + catch {puts stderr "timeout - closing.";flush stderr} + set command_pids "{%cpids%}" + if {[llength $command_pids]} { + set pid [lindex $command_pids 0] + if {$::tcl_platform(platform) eq "windows"} { + set killcmd [list [auto_execok taskkill] /F /PID $pid] + } else { + #set killcmd [list kill -9 $pid] + set killcmd [list kill -TERM $pid] + } + if {[catch { + exec {*}$killcmd + } errM]} { + puts stderr "Failed to kill '$pid': errMsg $errM" + flush stderr + } + } + if {[set ::shellfilter::shellcommandvars(%id%,exitcode)] ne ""} { + catch { chan close %wrerr% } + catch { chan close %rdout%} + catch { chan close %rderr%} + } else { + chan configure %rdout% -blocking 1 + try { + chan close %rdout% + set ::shellfilter::shellcommandvars(%id%,exitcode) 0 + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) CHILD PROCESS EXITED with code: $code" + } + set ::shellfilter::shellcommandvars(%id%,exitcode) $code + } trap CHILDKILLED {result options} { + set code [lindex [dict get $options -errorcode] 2] + #set code [dict get $options -code] + #set ::shellfilter::shellcommandvars(%id%,exitcode) $code + #set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled-timeout" + set ::shellfilter::shellcommandvars(%id%,exitcode) "childkilled-timeout" + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) CHILDKILLED with code: $code" + ::shellfilter::log::write %debugname% "(timeout) result:$result options:$options" + } + + } + catch { chan close %wrerr% } + catch { chan close %rderr%} + } + set %w% "timeout" + } + }]] + + + vwait $waitvar + after cancel $::shellfilter::shellcommandvars($call_id,timeoutid) + + #puts stderr "waitvar:[set $waitvar]" + #flush stderr + #if {[set $waitvar] eq "timeout"} { + # #note: attempting to kill a process here (after channels closed) doesn't work (on windows at least) + # puts stderr "command_pids: $command_pids" + # flush stderr + #} + + set exitcode [set ::shellfilter::shellcommandvars($call_id,exitcode)] + if {![string is digit -strict $exitcode]} { + puts stderr "Process exited with non-numeric code: $exitcode closed_by:[set $waitvar]" + flush stderr + } + if {[string length $teefile]} { + #cannot be called from within an event handler above.. vwait reentrancy etc + catch {::shellfilter::log::close $logname} + } + + if {$debug} { + ::shellfilter::log::write $debugname " closed by: [set $waitvar] with exitcode: $exitcode" + catch {::shellfilter::log::close $debugname} + } + array unset ::shellfilter::shellcommandvars $call_id,* + + + #restore buffering to pre shellfilter::run state + lassign $remember_in_out_err_buffering bin bout berr + chan configure $inchan -buffering $bin + chan configure $outchan -buffering $bout + chan configure $errchan -buffering $berr + + lassign $remember_in_out_err_translation tin tout terr + chan configure $inchan -translation $tin + chan configure $outchan -translation $tout + chan configure $errchan -translation $terr + + + #in channel probably closed..(? review - should it be?) + catch { + chan configure $inchan -buffering $bin + } + + + return [list exitcode $exitcode] + } + +} + +package provide shellfilter [namespace eval shellfilter { + variable version + set version 0.2.1 +}] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm index 3071ebd3..d776aba3 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm @@ -11069,8 +11069,8 @@ tcl::namespace::eval punk::args::argdocbase { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::args::package { variable PUNKARGS + # @dynamic not required? lappend PUNKARGS [list { - @dynamic @id -id "::punk::args::package::standard_about" @cmd -name "%pkg%::about" -help\ "About %pkg% diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.1.tm new file mode 100644 index 00000000..7b1098f3 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.1.tm @@ -0,0 +1,3348 @@ +#copyright 2023 Julian Marcel Noble +#license: BSD (revised 3-clause) +# +#Note shellfilter is currently only directly useful for unidirectional channels e.g stdin,stderr,stdout, or for example fifo2 where only one direction is being used. +#To generalize this to bidrectional channels would require shifting around read & write methods on transform objects in a very complicated manner. +#e.g each transform would probably be a generic transform container which holds sub-objects to which read & write are indirected. +#This is left as a future exercise...possibly it's best left as a concept for uni-directional channels anyway +# - as presumably the reads/writes from a bidirectional channel could be diverted off to unidirectional pipelines for processing with less work +# (and maybe even better speed/efficiency if the data volume is asymmetrical and there is significant processing on one direction) +# + + +tcl::namespace::eval shellfilter::log { + variable allow_adhoc_tags 1 + variable open_logs [tcl::dict::create] + variable is_enabled 0 + + proc disable {} { + variable is_enabled + set is_enabled 0 + proc ::shellfilter::log::open {tag settingsdict} {} + proc ::shellfilter::log::write {tag msg} {} + proc ::shellfilter::log::write_sync {tag msg} {} + proc ::shellfilter::log::close {tag} {} + } + + proc enable {} { + variable is_enabled + set is_enabled 1 + #'tag' is an identifier for the log source. + # each tag will use it's own thread to write to the configured log target + proc ::shellfilter::log::open {tag {settingsdict {}}} { + upvar ::shellfilter::sources sourcelist + if {![dict exists $settingsdict -tag]} { + tcl::dict::set settingsdict -tag $tag + } else { + #review + if {$tag ne [tcl::dict::get $settingsdict -tag]} { + error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" + } + } + if {$tag ni $sourcelist} { + lappend sourcelist $tag + } + + #note new_worker + set worker_tid [shellthread::manager::new_worker $tag $settingsdict] + #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" + return $worker_tid + } + proc ::shellfilter::log::write {tag msg} { + upvar ::shellfilter::sources sourcelist + variable allow_adhoc_tags + if {!$allow_adhoc_tags} { + if {$tag ni $sourcelist} { + error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag , and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags" + } + } + shellthread::manager::write_log $tag $msg + } + #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written + proc ::shellfilter::log::write_sync {tag msg} { + shellthread::manager::write_log $tag $msg -async 0 + } + proc ::shellfilter::log::close {tag} { + #shellthread::manager::close_worker $tag + shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed + } + + } + + #review + #configure whether we can call shellfilter::log::write without having called open first + proc require_open {{is_open_required {}}} { + variable allow_adhoc_tags + if {![string length $is_open_required]} { + return $allow_adhoc_tags + } else { + #why not use string is boolean? + set truevalues [list y yes true 1] + set falsevalues [list n no false 0] + if {[string tolower $is_open_required] in $truevalues} { + set allow_adhoc_tags 1 + } elseif {[string tolower $is_open_required] in $falsevalues} { + set allow_adhoc_tags 0 + } else { + error "shellfilter::log::require_open unrecognised value '$is_open_required' try one of $truevalues or $falsevalues" + } + } + } + if {[catch {package require shellthread}]} { + shellfilter::log::disable + } else { + shellfilter::log::enable + } + +} +namespace eval shellfilter::pipe { + #write channel for program. workerthread reads other end of fifo2 and writes data somewhere + proc open_out {tag_pipename {pipesettingsdict {}}} { + set defaultsettings {-buffering full} + set settingsdict [dict merge $defaultsettings $pipesettingsdict] + package require shellthread + #we are only using the fifo in a single direction to pipe to another thread + # - so whilst wchan and rchan could theoretically each be both read & write we're only using them for one operation each + if {![catch {package require Memchan}]} { + lassign [fifo2] wchan rchan + } else { + package require tcl::chan::fifo2 + lassign [tcl::chan::fifo2] wchan rchan + } + #default -translation for both types of fifo on windows is {auto crlf} + # -encoding is as per '[encoding system]' on the platform - e.g utf-8 (e.g windows when beta-utf8 enabled) + chan configure $wchan -buffering [dict get $settingsdict -buffering] ;# + #application end must not be binary for our filters to operate on it + + + #chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation binary ;#works reasonably.. + chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation lf + + set worker_tid [shellthread::manager::new_pipe_worker $tag_pipename $settingsdict] + #puts stderr "worker_tid: $worker_tid" + + #set_read_pipe does the thread::transfer of the rchan end. -buffering setting is maintained during thread transfer + shellthread::manager::set_pipe_read_from_client $tag_pipename $worker_tid $rchan + + set pipeinfo [list localchan $wchan remotechan $rchan workertid $worker_tid direction out] + return $pipeinfo + } + + #read channel for program. workerthread writes to other end of fifo2 from whereever it's reading (stdin, file?) + proc open_in {tag_pipename {settingsdict {} }} { + package require shellthread + package require tcl::chan::fifo2 + lassign [tcl::chan::fifo2] wchan rchan + set program_chan $rchan + set worker_chan $wchan + chan configure $worker_chan -buffering [dict get $settingsdict -buffering] + chan configure $program_chan -buffering [dict get $settingsdict -buffering] + + chan configure $program_chan -blocking 0 + chan configure $worker_chan -blocking 0 + set worker_tid [shellthread::manager::new_worker $tag_pipename $settingsdict] + + shellthread::manager::set_pipe_write_to_client $tag_pipename $worker_tid $worker_chan + + set pipeinfo [list localchan $program_chan remotechan $worker_chan workertid $worker_tid direction in] + puts stderr "|jn>pipe::open_in returning $pipeinfo" + puts stderr "program_chan: [chan conf $program_chan]" + return $pipeinfo + } + +} + + +namespace eval shellfilter::chan { + set testobj ::shellfilter::chan::var + if {$testobj ni [info commands $testobj]} { + + oo::class create var { + variable o_datavar + variable o_trecord + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + set varname [dict get $settingsdict -varname] + set o_datavar $varname + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 1 ;# as a var is diversionary - default it to be a jucntion + } + } + method initialize {ch mode} { + return [list initialize finalize write] + } + method finalize {ch} { + my destroy + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {ch count} { + # return ? + #} + method write {ch bytes} { + set stringdata [encoding convertfrom $o_enc $bytes] + append $o_datavar $stringdata + return "" + } + method meta_is_redirection {} { + return $o_is_junction + } + method meta_buffering_supported {} { + return [list line full none] + } + } + + #todo - something similar for multiple grep specs each with own -pre & -post .. store to dict? + oo::class create tee_grep_to_var { + variable o_datavar + variable o_lastxlines + variable o_trecord + variable o_grepfor + variable o_prelines + variable o_postlines + variable o_postcountdown + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_lastxlines [list] + set o_postcountdown 0 + set defaults [tcl::dict::create -pre 1 -post 1] + set settingsdict [tcl::dict::get $tf -settings] + set settings [tcl::dict::merge $defaults $settingsdict] + set o_datavar [tcl::dict::get $settings -varname] + set o_grepfor [tcl::dict::get $settings -grep] + set o_prelines [tcl::dict::get $settings -pre] + set o_postlines [tcl::dict::get $settings -post] + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize finalize write] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #method read {transform_handle count} { + # return ? + #} + method write {transform_handle bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set lastx $o_lastxlines + lappend o_lastxlines $logdata + + if {$o_postcountdown > 0} { + append $o_datavar $logdata + if {[regexp $o_grepfor $logdata]} { + #another match in postlines + set o_postcountdown $o_postlines + } else { + incr o_postcountdown -1 + } + } else { + if {[regexp $o_grepfor $logdata]} { + append $o_datavar [join $lastx] + append $o_datavar $logdata + set o_postcountdown $o_postlines + } + } + + if {[llength $o_lastxlines] > $o_prelines} { + set o_lastxlines [lrange $o_lastxlines 1 end] + } + return $bytes + } + method meta_is_redirection {} { + return $o_is_junction + } + method meta_buffering_supported {} { + return [list line] + } + } + + oo::class create tee_to_var { + variable o_datavars + variable o_trecord + variable o_enc + variable o_encbuf + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_encbuf "" + set settingsdict [tcl::dict::get $tf -settings] + set varname [tcl::dict::get $settingsdict -varname] + set o_datavars $varname + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {ch mode} { + return [list initialize finalize write flush clear] + } + method finalize {ch} { + my destroy + } + method clear {ch} { + return + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {ch count} { + # return ? + #} + #method flush {ch} { + # return "" + #} + method flush {transform_handle} { + #puts stdout "" + #review - just clear o_encbuf and emit nothing? + #we wouldn't have a value there if it was convertable from the channel encoding? + set clear $o_encbuf + set o_encbuf "" + return $o_encbuf + } + method write {ch bytes} { + #test with set x [string repeat " \U1f6c8" 2043] + #or + #test with set x [string repeat " \U1f6c8" 683] + #most windows terminals (at least) may emit two unrecognised chars "??" at the end + + #Our goal with the while loop here is to avoid encoding conversion errors + #the source of the bogus chars in terminals is unclear. + #Alacritty on windows doesn't seem to have the problem, but wezterm,cmd,windows terminal do. + + #set stringdata [tcl::encoding::convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [string length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [string range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + + foreach v $o_datavars { + append $v $stringdata + } + #return $bytes + return [string range $inputbytes 0 end-$tail_offset] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + oo::class create tee_to_pipe { + variable o_logsource + variable o_localchan + variable o_enc + variable o_encbuf + variable o_trecord + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_encbuf "" + set settingsdict [tcl::dict::get $tf -settings] + if {![dict exists $settingsdict -tag]} { + error "tee_to_pipe constructor settingsdict missing -tag" + } + set o_localchan [tcl::dict::get $settingsdict -pipechan] + set o_logsource [tcl::dict::get $settingsdict -tag] + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize read drain write flush clear finalize] + } + method finalize {transform_handle} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {transform_handle events} { + # must be present but we ignore it because we do not + # post any events + } + method clear {transform_handle} { + return + } + method drain {transform_handle} { + return "" + } + method read {transform_handle bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + #::shellfilter::log::write $o_logsource $logdata + puts -nonewline $o_localchan $logdata + return $bytes + } + method flush {transform_handle} { + #return "" + set clear $o_encbuf + set o_encbuf "" + return $o_encbuf + } + method write {transform_handle bytes} { + #set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + #::shellfilter::log::write $o_logsource $logdata + puts -nonewline $o_localchan $stringdata + #return $bytes + return [::tcl::string::range $inputbytes 0 end-$tail_offset] + } + #a tee is not a redirection - because data still flows along the main path + method meta_is_redirection {} { + return $o_is_junction + } + + } + oo::class create tee_to_log { + variable o_tid + variable o_logsource + variable o_trecord + variable o_enc + variable o_encbuf + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_encbuf "" + set settingsdict [tcl::dict::get $tf -settings] + if {![tcl::dict::exists $settingsdict -tag]} { + error "tee_to_log constructor settingsdict missing -tag" + } + set o_logsource [tcl::dict::get $settingsdict -tag] + set o_tid [::shellfilter::log::open $o_logsource $settingsdict] + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {ch mode} { + return [list initialize read write flush finalize] + } + method finalize {ch} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + method read {ch bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + ::shellfilter::log::write $o_logsource $logdata + return $bytes + } + method flush {transform_handle} { + #return "" + set clear $o_encbuf + set o_encbuf "" + return $o_encbuf + } + method write {ch bytes} { + #set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + set bytes [::tcl::string::range $inputbytes 0 end-$tail_offset] + ::shellfilter::log::write $o_logsource $stringdata + return $bytes + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + + oo::class create logonly { + variable o_tid + variable o_logsource + variable o_trecord + variable o_enc + variable o_encbuf + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set o_encbuf "" + set settingsdict [dict get $tf -settings] + if {![dict exists $settingsdict -tag]} { + error "logonly constructor settingsdict missing -tag" + } + set o_logsource [dict get $settingsdict -tag] + set o_tid [::shellfilter::log::open $o_logsource $settingsdict] + } + method initialize {transform_handle mode} { + return [list initialize finalize write] + } + method finalize {transform_handle} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {transform_handle events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {transform_handle count} { + # return ? + #} + method write {transform_handle bytes} { + #set logdata [encoding convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return + } + } + + #::shellfilter::log::write_sync $o_logsource $logdata + ::shellfilter::log::write $o_logsource $stringdata + return + } + method meta_is_redirection {} { + return 1 + } + } + + #review - we should probably provide a more narrow filter than only strips color - and one that strips most(?) + # - but does it ever really make sense to strip things like "esc(0" and "esc(B" which flip to the G0 G1 characters? (once stripped - things like box-lines become ordinary letters - unlikely to be desired?) + #punk::ansi::ansistrip converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion + #assumes line-buffering. a more advanced filter required if ansicodes can arrive split across separate read or write operations! + oo::class create ansistrip { + variable o_trecord + variable o_enc + variable o_encbuf + variable o_is_junction + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [::tcl::dict::get $tf -encoding] + set o_encbuf "" + if {[::tcl::dict::exists $tf -junction]} { + set o_is_junction [::tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize read write clear flush drain finalize] + } + method finalize {transform_handle} { + my destroy + } + method clear {transform_handle} { + return + } + method watch {transform_handle events} { + } + method drain {transform_handle} { + return "" + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + set outstring [punk::ansi::ansistrip $instring] + return [encoding convertto $o_enc $outstring] + } + method flush {transform_handle} { + return "" + } + #method write {transform_handle bytes} { + # #broken due to occasional unexpected byte sequence + # set instring [encoding convertfrom $o_enc $bytes] + # set outstring [punk::ansi::ansistrip $instring] + # return [encoding convertto $o_enc $outstring] + #} + method write {transform_handle bytes} { + #set instring [tcl::encoding::convertfrom $o_enc $bytes] ;naive approach will break due to unexpected byte sequence - occasionally + #bytes can break at arbitrary points making encoding conversions invalid. + + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + + set outstring [punk::ansi::ansistrip $stringdata] + return [tcl::encoding::convertto $o_enc $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + #a test + oo::class create reconvert { + variable o_trecord + variable o_enc + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + } + method initialize {transform_handle mode} { + return [list initialize read write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + } + oo::define reconvert { + method meta_is_redirection {} { + return 0 + } + } + + + #this isn't a particularly nice thing to do to a stream - especially if someone isn't expecting ansi codes sprinkled through it. + #It can be useful for test/debugging + #Due to chunking at random breaks - we have to check if an ansi code in the underlying stream has been split - otherwise our wrapping will break the existing ansi + # + set sixelstart_re {\x1bP([;0-9]*)q} ;#7-bit - todo 8bit + #todo kitty graphics \x1b_G... + #todo iterm graphics + + oo::class create ansiwrap { + variable o_trecord + variable o_enc + variable o_encbuf ;#buffering for partial encoding bytes + variable o_colour + variable o_do_colour + variable o_do_colourlist + variable o_do_normal + variable o_is_junction + variable o_codestack + variable o_gx_state ;#on/off alt graphics + variable o_buffered ;#buffering for partial ansi codes + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set settingsdict [tcl::dict::get $tf -settings] + if {[tcl::dict::exists $settingsdict -colour]} { + set o_colour [tcl::dict::get $settingsdict -colour] + #warning - we can't merge certain extended attributes such as undercurly into single SGR escape sequence + #while some terminals may handle these extended attributes even when merged - we need to cater for those that + #don't. Keeping them as a separate escape allows terminals that don't handle them to ignore just that code without + #affecting the interpretation of the other codes. + set o_do_colour [punk::ansi::a+ {*}$o_colour] + set o_do_colourlist [punk::ansi::ta::get_codes_single $o_do_colour] + set o_do_normal [punk::ansi::a] + } else { + set o_colour {} + set o_do_colour "" + set o_do_colourlist {} + set o_do_normal "" + } + set o_codestack [list] + set o_gx_state [expr {off}] + set o_encbuf "" + set o_buffered "" ;#hold back data that potentially contains partial ansi codes + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + + + #todo - track when in sixel,iterm,kitty graphics data - can be very large + method Trackcodes {chunk} { + #note - caller can use 2 resets in a single unit to temporarily reset to no sgr (override ansiwrap filter) + #e.g [a+ reset reset] (0;0m vs 0;m) + + #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]" + set buf $o_buffered$chunk + set emit "" + if {[string last \x1b $buf] >= 0} { + #detect will detect ansi SGR and gron groff and other codes + #REVIEW - ta::detect won't detect SOS without paired ST for things like PM + # ta::detectcode will - but then split_codes_single will treat unpaired SOS as text? + if {[punk::ansi::ta::detect $buf]} { + #split_codes_single regex faster than split_codes - but more resulting parts + #'single' refers to number of escapes - but can still contain e.g multiple SGR codes (or mode set operations etc) + set parts [punk::ansi::ta::split_codes_single $buf] + #process all pt/code pairs except for trailing pt + foreach {pt code} [lrange $parts 0 end-1] { + #puts "<==[ansistring VIEW -lf 1 $pt]==>" + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$pt + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$pt + } + } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # append emit $o_do_colour$pt$o_do_normal + # #append emit $pt + #} else { + # append emit $pt + #} + + set c1c2 [tcl::string::range $code 0 1] + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + ] $c1c2] 0 3] + switch -- $leadernorm { + 7CSI - 8CSI { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set o_codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set o_codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #todo - make caching is_sgr method + set dup_posns [lsearch -all -exact $o_codestack $code] + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $code + } else { + + } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set o_gx_state on + } + "B" { + set o_gx_state off + } + } + } + default { + #other ansi codes + } + } + append emit $code + } + + + set trailing_pt [lindex $parts end] + if {[string first \x1b $trailing_pt] >= 0} { + #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'" + #may not be plaintext after all + set o_buffered $trailing_pt + #puts stdout "=-=[ansistring VIEWCODES $o_buffered]" + } else { + #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a] + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$trailing_pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$trailing_pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$trailing_pt + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$trailing_pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$trailing_pt + } + } + #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { + # append emit $o_do_colour$trailing_pt$o_do_normal + #} else { + # append emit $trailing_pt + #} + #the previous o_buffered formed the data we emitted - nothing new to buffer because we emitted all parts including the trailing plaintext + set o_buffered "" + } + + + } else { + #REVIEW - this holding a buffer without emitting as we go is ugly. + # - we may do better to detect and retain the opener, then use that opener to avoid false splits within the sequence. + # - we'd then need to detect the appropriate close to restart splitting and codestacking + # - we may still need to retain and append the data to the opener (in some cases?) - which is a slight memory issue - but at least we would emit everything immediately. + + + #puts "-->esc but no detect" + #no complete ansi codes - but at least one esc is present + if {[string index $buf end] eq "\x1b" && [string first \x1b $buf] == [string length $buf]-1} { + #string index in first part of && clause to avoid some unneeded scans of whole string for this test + #we can't use 'string last' - as we need to know only esc is last char in buf + #puts ">>trailing-esc<<" + set o_buffered \x1b + set emit $o_do_colour[string range $buf 0 end-1]$o_do_normal + #set emit [string range $buf 0 end-1] + set buf "" + } else { + set emit_anyway 0 + #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer + if {[punk::ansi::ta::detect_st_open $buf]} { + #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms) + set st_partial_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code + #todo - configurable ST max - use 1k for now + if {$st_partial_len < 1001} { + append o_buffered $chunk + set emit "" + set buf "" + } else { + set emit_anyway 1 + set o_buffered "" + } + } else { + set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code + #most opening sequences are 1,2 or 3 chars - review? + set open_sequence_detected [punk::ansi::ta::detect_open $buf] + if {$possible_code_len > 10 && !$open_sequence_detected} { + set emit_anyway 1 + set o_buffered "" + } else { + #could be composite sequence with params - allow some reasonable max sequence length + #todo - configurable max sequence length + #len 40-50 quite possible for SGR sequence using coloured underlines etc, even without redundancies + # - allow some headroom for redundant codes when the caller didn't merge. + if {$possible_code_len < 101} { + append o_buffered $chunk + set buf "" + set emit "" + } else { + #allow a little more grace if we at least have an opening ansi sequence of any type.. + if {$open_sequence_detected && $possible_code_len < 151} { + append o_buffered $chunk + set buf "" + set emit "" + } else { + set emit_anyway 1 + set o_buffered "" + } + } + } + } + if {$emit_anyway} { + #assert: any time emit_anyway == 1 buf already contains all of previous o_buffered and o_buffered has been cleared. + + #looked ansi-like - but we've given enough length without detecting close.. + #treat as possible plain text with some esc or unrecognised ansi sequence + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # set emit $o_do_colour$buf$o_do_normal + #} else { + # set emit $buf + #} + } + } + } + } else { + #no esc + #puts stdout [a+ yellow]...[a] + #test! + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + set o_buffered "" + } + return [dict create emit $emit stacksize [llength $o_codestack]] + } + method initialize {transform_handle mode} { + #clear undesirable in terminal output channels (review) + return [list initialize write flush read drain finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method clear {transform_handle} { + #In the context of stderr/stdout - we probably don't want clear to run. + #Terminals might call it in the middle of a split ansi code - resulting in broken output. + #Leave clear of it the init call + puts stdout "" + set emit [tcl::encoding::convertto $o_enc $o_buffered] + set o_buffered "" + return $emit + } + method flush {transform_handle} { + #puts stdout "" + set inputbytes $o_buffered$o_encbuf + set emit [tcl::encoding::convertto $o_enc $inputbytes] + set o_buffered "" + set o_encbuf "" + return $emit + } + method write {transform_handle bytes} { + #set instring [tcl::encoding::convertfrom $o_enc $bytes] ;naive approach will break due to unexpected byte sequence - occasionally + #bytes can break at arbitrary points making encoding conversions invalid. + + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [string length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [string range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + set streaminfo [my Trackcodes $stringdata] + set emit [dict get $streaminfo emit] + + #review - wrapping already done in Trackcodes + #if {[dict get $streaminfo stacksize] == 0} { + # #no ansi on the stack - we can wrap + # #review + # set outstring "$o_do_colour$emit$o_do_normal" + #} else { + #} + #if {[llength $o_codestack]} { + # set outstring [punk::ansi::codetype::sgr_merge_singles $o_codestack]$emit + #} else { + # set outstring $emit + #} + #set outstring $emit + + #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<" + #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<" + return [tcl::encoding::convertto $o_enc $emit] + } + method Write_naive {transform_handle bytes} { + set instring [tcl::encoding::convertfrom $o_enc $bytes] + set outstring "$o_do_colour$instring$o_do_normal" + #set outstring ">>>$instring" + return [tcl::encoding::convertto $o_enc $outstring] + } + method drain {transform_handle} { + return "" + } + method read {transform_handle bytes} { + set instring [tcl::encoding::convertfrom $o_enc $bytes] + set outstring "$o_do_colour$instring$o_do_normal" + return [tcl::encoding::convertto $o_enc $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + #todo - something + oo::class create rebuffer { + variable o_trecord + variable o_enc + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + } + method initialize {transform_handle mode} { + return [list initialize read write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + #set outstring [string map [list \n ] $instring] + set outstring $instring + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define rebuffer { + method meta_is_redirection {} { + return 0 + } + } + + #has slight buffering/withholding of lone training cr - we can't be sure that a cr at end of chunk is part of \r\n sequence + oo::class create tounix { + variable o_trecord + variable o_enc + variable o_last_char_was_cr + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + set o_last_char_was_cr 0 + } + method initialize {transform_handle mode} { + return [list initialize write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #don't use read + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + #set outstring [string map [list \n ] $instring] + + if {$o_last_char_was_cr} { + set instring "\r$instring" + } + + set outstring [string map {\r\n \n} $instring] + set lastchar [string range $outstring end end] + if {$lastchar eq "\r"} { + set o_last_char_was_cr 1 + set outstring [string range $outstring 0 end-1] + } else { + set o_last_char_was_cr 0 + } + #review! can we detect eof here on the transform_handle? + #if eof, we don't want to strip a trailing \r + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define tounix { + method meta_is_redirection {} { + return $o_is_junction + } + } + #write to handle case where line-endings already \r\n too + oo::class create towindows { + variable o_trecord + variable o_enc + variable o_last_char_was_cr + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + set o_last_char_was_cr 0 + } + method initialize {transform_handle mode} { + return [list initialize write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #don't use read + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + #set outstring [string map [list \n ] $instring] + + if {$o_last_char_was_cr} { + set instring "\r$instring" + } + + set outstring [string map {\r\n \uFFFF} $instring] + set outstring [string map {\n \r\n} $outstring] + set outstring [string map {\uFFFF \r\n} $outstring] + + set lastchar [string range $outstring end end] + if {$lastchar eq "\r"} { + set o_last_char_was_cr 1 + set outstring [string range $outstring 0 end-1] + } else { + set o_last_char_was_cr 0 + } + #review! can we detect eof here on the transform_handle? + #if eof, we don't want to strip a trailing \r + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define towindows { + method meta_is_redirection {} { + return $o_is_junction + } + } + + } +} + +# ---------------------------------------------------------------------------- +#review float/sink metaphor. +#perhaps something with the concept of upstream and downstream? +#need concepts for push towards data, sit in middle where placed, and lag at tail of data stream. +## upstream for stdin is at the bottom of the stack and for stdout is the top of the stack. +#upstream,neutral-upstream,downstream,downstream-aside,downstream-replace (default neutral-upstream - require action 'stack' to use standard channel stacking concept and ignore other actions) +#This is is a bit different from the float/sink metaphor which refers to the channel stacking order as opposed to the data-flow direction. +#The idea would be that whether input or output +# upstream additions go to the side closest to the datasource +# downstream additions go furthest from the datasource +# - all new additions go ahead of any diversions as the most upstream diversion is the current end of the stream in a way. +# - this needs review regarding subsequent removal of the diversion and whether filters re-order in response.. +# or if downstream & neutral additions are reclassified upon insertion if they land among existing upstreams(?) +# neutral-upstream goes to the datasource side of the neutral-upstream list. +# No 'neutral' option provided so that we avoid the need to think forwards or backwards when adding stdin vs stdout shellfilter does the necessary pop/push reordering. +# No 'neutral-downstream' to reduce complexity. +# downstream-replace & downstream-aside head downstream to the first diversion they encounter. ie these actions are no longer referring to the stack direction but only the dataflow direction. +# +# ---------------------------------------------------------------------------- +# +# 'filters' are transforms that don't redirect +# - limited range of actions to reduce complexity. +# - any requirement not fulfilled by float,sink,sink-replace,sink-sideline should be done by multiple pops and pushes +# +#actions can float to top of filters or sink to bottom of filters +#when action is of type sink, it can optionally replace or sideline the first non-filter it encounters (highest redirection on the stack.. any lower are starved of the stream anyway) +# - sideline means to temporarily replace the item and keep a record, restoring if/when we are removed from the transform stack +# +##when action is of type float it can't replace or sideline anything. A float is added above any existing floats and they stay in the same order relative to each other, +#but non-floats added later will sit below all floats. +#(review - float/sink initially designed around output channels. For stdin the dataflow is reversed. implement float-aside etc?) +# +# +#action: float sink sink-replace,sink-sideline +# +# +## note - whether stack is for input or output we maintain it in the same direction - which is in sync with the tcl chan pop chan push concept. +## +namespace eval shellfilter::stack { + namespace export {[a-z]*} + namespace ensemble create + #todo - implement as oo ? + variable pipelines [list] + + proc items {} { + #review - stdin,stdout,stderr act as pre-existing pipelines, and we can't create a new one with these names - so they should probably be autoconfigured and listed.. + # - but in what contexts? only when we find them in [chan names]? + variable pipelines + return [dict keys $pipelines] + } + proc item {pipename} { + variable pipelines + return [dict get $pipelines $pipename] + } + proc item_tophandle {pipename} { + variable pipelines + set handle "" + if {[dict exists $pipelines $pipename stack]} { + set stack [dict get $pipelines $pipename stack] + set topstack [lindex $stack end] ;#last item in stack is top (for output channels anyway) review comment. input chans? + if {$topstack ne ""} { + if {[dict exists $topstack -handle]} { + set handle [dict get $topstack -handle] + } + } + } + return $handle + } + proc status {{pipename *} args} { + variable pipelines + set pipecount [dict size $pipelines] + set tabletitle "$pipecount pipelines active" + set t [textblock::class::table new $tabletitle] + $t add_column -headers [list channel-ident] + $t add_column -headers [list device-info localchan] + $t configure_column 1 -header_colspans {3} + $t add_column -headers [list "" remotechan] + $t add_column -headers [list "" tid] + $t add_column -headers [list stack-info] + foreach k [dict keys $pipelines $pipename] { + set lc [dict get $pipelines $k device localchan] + set rc [dict get $pipelines $k device remotechan] + if {[dict exists $k device workertid]} { + set tid [dict get $pipelines $k device workertid] + } else { + set tid "-" + } + set stack [dict get $pipelines $k stack] + if {![llength $stack]} { + set stackinfo "" + } else { + set tbl_inner [textblock::class::table new] + $tbl_inner configure -show_edge 0 + foreach rec $stack { + set handle [punk::lib::dict_getdef $rec -handle ""] + set id [punk::lib::dict_getdef $rec -id ""] + set transform [namespace tail [punk::lib::dict_getdef $rec -transform ""]] + set settings [punk::lib::dict_getdef $rec -settings ""] + $tbl_inner add_row [list $id $transform $handle $settings] + } + set stackinfo [$tbl_inner print] + $tbl_inner destroy + } + $t add_row [list $k $lc $rc $tid $stackinfo] + } + set result [$t print] + $t destroy + return $result + } + proc status1 {{pipename *} args} { + variable pipelines + + set pipecount [dict size $pipelines] + set tableprefix "$pipecount pipelines active\n" + foreach p [dict keys $pipelines] { + append tableprefix " " $p \n + } + package require overtype + #todo -verbose + set table "" + set ac1 [string repeat " " 15] + set ac2 [string repeat " " 42] + set ac3 [string repeat " " 70] + append table "[overtype::left $ac1 channel-ident] " + append table "[overtype::left $ac2 device-info] " + append table "[overtype::left $ac3 stack-info]" + append table \n + + + set bc1 [string repeat " " 5] ;#stack id + set bc2 [string repeat " " 25] ;#transform + set bc3 [string repeat " " 50] ;#settings + + foreach k [dict keys $pipelines $pipename] { + set lc [dict get $pipelines $k device localchan] + if {[dict exists $k device workertid]} { + set tid [dict get $pipelines $k device workertid] + } else { + set tid "" + } + + + set col1 [overtype::left $ac1 $k] + set col2 [overtype::left $ac2 "localchan: $lc tid:$tid"] + + set stack [dict get $pipelines $k stack] + if {![llength $stack]} { + set col3 $ac3 + } else { + set rec [lindex $stack 0] + set bcol1 [overtype::left $bc1 [dict get $rec -id]] + set bcol2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] + set bcol3 [overtype::left $bc3 [dict get $rec -settings]] + set stackrow "$bcol1 $bcol2 $bcol3" + set col3 [overtype::left $ac3 $stackrow] + } + + append table "$col1 $col2 $col3\n" + + + foreach rec [lrange $stack 1 end] { + set col1 $ac1 + set col2 $ac2 + if {[llength $rec]} { + set bc1 [overtype::left $bc1 [dict get $rec -id]] + set bc2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] + set bc3 [overtype::left $bc3 [dict get $rec -settings]] + set stackrow "$bc1 $bc2 $bc3" + set col3 [overtype::left $ac3 $stackrow] + } else { + set col3 $ac3 + } + append table "$col1 $col2 $col3\n" + } + + } + return $tableprefix$table + } + #used for output channels - we usually want to sink redirections below the floaters and down to topmost existing redir + proc _get_stack_floaters {stack} { + set floaters [list] + foreach t [lreverse $stack] { + switch -- [dict get $t -action] { + float { + lappend floaters $t + } + default { + break + } + } + } + return [lreverse $floaters] + } + + + + #for output-channel sinking + proc _get_stack_top_redirection {stack} { + set r 0 ;#reverse index + foreach t [lreverse $stack] { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index + return [list index $idx record $t] + } + incr r + } + #not found + return [list index -1 record {}] + } + #exclude float-locked, locked, sink-locked + proc _get_stack_top_redirection_replaceable {stack} { + set r 0 ;#reverse index + foreach t [lreverse $stack] { + set action [dict get $t -action] + if {![string match "*locked*" $action]} { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index + return [list index $idx record $t] + } + } + incr r + } + #not found + return [list index -1 record {}] + } + + + #for input-channels ? + proc _get_stack_bottom_redirection {stack} { + set i 0 + foreach t $stack { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + return [linst index $i record $t] + } + incr i + } + #not found + return [list index -1 record {}] + } + + + proc get_next_counter {pipename} { + variable pipelines + #use dictn incr ? + set counter [dict get $pipelines $pipename counter] + incr counter + dict set pipelines $pipename counter $counter + return $counter + } + + proc unwind {pipename} { + variable pipelines + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $pipelines $pipename device localchan] + foreach tf [lreverse $stack] { + chan pop $localchan + } + dict set pipelines $pipename [list] + } + #todo + proc delete {pipename {wait 0}} { + variable pipelines + set pipeinfo [dict get $pipelines $pipename] + set deviceinfo [dict get $pipeinfo device] + set localchan [dict get $deviceinfo localchan] + unwind $pipename + + #release associated thread + set tid [dict get $deviceinfo workertid] + if {$wait} { + thread::release -wait $tid + } else { + thread::release $tid + } + + #Memchan closes without error - tcl::chan::fifo2 raises something like 'can not find channel named "rc977"' - REVIEW. why? + catch {chan close $localchan} + } + #review - proc name clarity is questionable. remove_stackitem? + proc remove {pipename remove_id} { + variable pipelines + if {![dict exists $pipelines $pipename]} { + puts stderr "WARNING: shellfilter::stack::remove pipename '$pipename' not found in pipelines dict: '$pipelines' [info level -1]" + return + } + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $pipelines $pipename device localchan] + set posn 0 + set idposn -1 + set asideposn -1 + foreach t $stack { + set id [dict get $t -id] + if {$id eq $remove_id} { + set idposn $posn + break + } + #look into asides (only can be one for now) + if {[llength [dict get $t -aside]]} { + set a [dict get $t -aside] + if {[dict get $a -id] eq $remove_id} { + set asideposn $posn + break + } + } + incr posn + } + + if {$asideposn > 0} { + #id wasn't found directly in stack, but in an -aside. we don't need to pop anything - just clear this aside record + set container [lindex $stack $asideposn] + dict set container -aside {} + lset stack $asideposn $container + dict set pipelines $pipename stack $stack + } else { + if {$idposn < 0} { + ::shellfilter::log::write shellfilter "ERROR shellfilter::stack::remove $pipename id '$remove_id' not found" + puts stderr "|WARNING>shellfilter::stack::remove $pipename id '$remove_id' not found" + return 0 + } + set removed_item [lindex $stack $idposn] + + #include idposn in poplist + set poplist [lrange $stack $idposn end] + set stack [lreplace $stack $idposn end] + #pop all chans before adding anything back in! + foreach p $poplist { + chan pop $localchan + } + + if {[llength [dict get $removed_item -aside]]} { + set restore [dict get $removed_item -aside] + set t [dict get $restore -transform] + set tsettings [dict get $restore -settings] + set obj [$t new $restore] + set h [chan push $localchan $obj] + dict set restore -handle $h + dict set restore -obj $obj + lappend stack $restore + } + + #put popped back except for the first one, which we want to remove + foreach p [lrange $poplist 1 end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + dict set p -handle $h + dict set p -obj $obj + lappend stack $p + } + dict set pipelines $pipename stack $stack + } + #JMNJMN 2025 review! + #show_pipeline $pipename -note "after_remove $remove_id" + return 1 + } + + #pop a number of items of the top of the stack, add our transform record, and add back all (or the tail of poplist if pushstartindex > 0) + proc insert_transform {pipename stack transformrecord poplist {pushstartindex 0}} { + variable pipelines + set bottom_pop_posn [expr {[llength $stack] - [llength $poplist]}] + set poplist [lrange $stack $bottom_pop_posn end] + set stack [lreplace $stack $bottom_pop_posn end] + + set localchan [dict get $pipelines $pipename device localchan] + foreach p [lreverse $poplist] { + chan pop $localchan + } + set transformname [dict get $transformrecord -transform] + set transformsettings [dict get $transformrecord -settings] + set obj [$transformname new $transformrecord] + set h [chan push $localchan $obj] + dict set transformrecord -handle $h + dict set transformrecord -obj $obj + dict set transformrecord -note "insert_transform" + lappend stack $transformrecord + foreach p [lrange $poplist $pushstartindex end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + #retain previous -id - code that added it may have kept reference and not expecting it to change + dict set p -handle $h + dict set p -obj $obj + dict set p -note "re-added" + + lappend stack $p + } + return $stack + } + + #fifo2 + proc new {pipename args} { + variable pipelines + if {($pipename in [dict keys $pipelines]) || ($pipename in [chan names])} { + error "shellfilter::stack::new error: pipename '$pipename' already exists" + } + + set opts [dict merge {-settings {}} $args] + set defaultsettings [dict create -raw 1 -buffering line -direction out] + set targetsettings [dict merge $defaultsettings [dict get $opts -settings]] + + set direction [dict get $targetsettings -direction] + + #pipename is the source/facility-name ? + if {$direction eq "out"} { + set pipeinfo [shellfilter::pipe::open_out $pipename $targetsettings] + } else { + puts stderr "|jn> pipe::open_in $pipename $targetsettings" + set pipeinfo [shellfilter::pipe::open_in $pipename $targetsettings] + } + #open_out/open_in will configure buffering based on targetsettings + + set program_chan [dict get $pipeinfo localchan] + set worker_chan [dict get $pipeinfo remotechan] + set workertid [dict get $pipeinfo workertid] + + + set deviceinfo [dict create pipename $pipename localchan $program_chan remotechan $worker_chan workertid $workertid direction $direction] + dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] + + return $deviceinfo + } + #we 'add' rather than 'push' because transforms can float,sink and replace/sideline so they don't necessarily go to the top of the transform stack + proc add {pipename transformname args} { + variable pipelines + #chan names doesn't reflect available channels when transforms are in place + #e.g stdout may exist but show as something like file191f5b0dd80 + if {($pipename ni [dict keys $pipelines])} { + if {[catch {eof $pipename} is_eof]} { + error "shellfilter::stack::add no existing chan or pipename matching '$pipename' in channels:[chan names] or pipelines:$pipelines use stdin/stderr/stdout or shellfilter::stack::new " + } + } + set args [dict merge {-action "" -settings {}} $args] + set action [dict get $args -action] + set transformsettings [dict get $args -settings] + if {[string first "::" $transformname] < 0} { + set transformname ::shellfilter::chan::$transformname + } + if {![llength [info commands $transformname]]} { + error "shellfilter::stack::push unknown transform '$transformname'" + } + + + if {![dict exists $pipelines $pipename]} { + #pipename must be in chan names - existing device/chan + #record a -read and -write end even if the device is only being used as one or the other + set deviceinfo [dict create pipename $pipename localchan $pipename remotechan {}] + dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] + } else { + set deviceinfo [dict get $pipelines $pipename device] + } + + set id [get_next_counter $pipename] + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $deviceinfo localchan] + + #we redundantly store chan in each transform - makes debugging clearer + # -encoding similarly could be stored only at the pipeline level (or even queried directly each filter-read/write), + # but here it may help detect unexpected changes during lifetime of the stack and avoids the chance of callers incorrectly using the transform handle?) + # jn + set transform_record [list -id $id -chan $pipename -encoding [chan configure $localchan -encoding] -transform $transformname -aside {} {*}$args] + switch -glob -- $action { + float - float-locked { + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + lappend stack $transform_record + } + "" - locked { + set floaters [_get_stack_floaters $stack] + if {![llength $floaters]} { + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + lappend stack $transform_record + } else { + set poplist $floaters + set stack [insert_transform $pipename $stack $transform_record $poplist] + } + } + "sink*" { + set redirinfo [_get_stack_top_redirection $stack] + set idx_existing_redir [dict get $redirinfo index] + if {$idx_existing_redir == -1} { + #no existing redirection transform on the stack + #pop everything.. add this record as the first redirection on the stack + set poplist $stack + set stack [insert_transform $pipename $stack $transform_record $poplist] + } else { + switch -glob -- $action { + "sink-replace" { + #include that index in the poplist + set poplist [lrange $stack $idx_existing_redir end] + #pop all from idx_existing_redir to end, but put back 'lrange $poplist 1 end' + set stack [insert_transform $pipename $stack $transform_record $poplist 1] + } + "sink-aside*" { + set existing_redir_record [lindex $stack $idx_existing_redir] + if {[string match "*locked*" [dict get $existing_redir_record -action]]} { + set put_aside 0 + #we can't aside this one - sit above it instead. + set poplist [lrange $stack $idx_existing_redir+1 end] + set stack [lrange $stack 0 $idx_existing_redir] + } else { + set put_aside 1 + dict set transform_record -aside [lindex $stack $idx_existing_redir] + set poplist [lrange $stack $idx_existing_redir end] + set stack [lrange $stack 0 $idx_existing_redir-1] + } + foreach p $poplist { + chan pop $localchan + } + set transformname [dict get $transform_record -transform] + set transform_settings [dict get $transform_record -settings] + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + dict set transform_record -note "insert_transform-with-aside" + lappend stack $transform_record + #add back poplist *except* the one we transferred into -aside (if we were able) + foreach p [lrange $poplist $put_aside end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + #retain previous -id - code that added it may have kept reference and not expecting it to change + dict set p -handle $h + dict set p -obj $obj + dict set p -note "re-added-after-sink-aside" + lappend stack $p + } + } + default { + #plain "sink" + #we only sink to the topmost redirecting filter - which makes sense for an output channel + #For stdin.. this is more problematic as we're more likely to want to intercept the bottom most redirection. + #todo - review. Consider making default insert position for input channels to be at the source... and float/sink from there. + # - we don't currently know from the stack api if adding input vs output channel - so this needs work to make intuitive. + # consider splitting stack::add to stack::addinput stack::addoutput to split the different behaviour + set poplist [lrange $stack $idx_existing_redir+1 end] + set stack [insert_transform $pipename $stack $transform_record $poplist] + } + } + } + } + default { + error "shellfilter::stack::add unimplemented action '$action'" + } + } + + dict set pipelines $pipename stack $stack + #puts stdout "==" + #puts stdout "==>stack: $stack" + #puts stdout "==" + + #JMNJMN + #show_pipeline $pipename -note "after_add $transformname $args" + return $id + } + proc show_pipeline {pipename args} { + variable pipelines + set stack [dict get $pipelines $pipename stack] + set tag "SHELLFILTER::STACK" + #JMN - load from config + #::shellfilter::log::open $tag {-syslog 127.0.0.1:514} + if {[catch { + ::shellfilter::log::open $tag {-syslog ""} + } err]} { + #e.g safebase interp can't load required modules such as shellthread (or Thread) + puts stderr "shellfilter::show_pipeline cannot open log" + return + } + ::shellfilter::log::write $tag "transform stack for $pipename $args" + foreach tf $stack { + ::shellfilter::log::write $tag " $tf" + } + + } +} + + +namespace eval shellfilter { + variable sources [list] + variable stacks [dict create] + + proc ::shellfilter::redir_channel_to_log {chan args} { + variable sources + set default_logsettings [dict create \ + -tag redirected_$chan -syslog "" -file ""\ + ] + if {[dict exists $args -action]} { + set action [dict get $args -action] + } else { + # action "sink" is a somewhat reasonable default for an output redirection transform + # but it can make it harder to configure a plain ordered stack if the user is not expecting it, so we'll default to stack + # also.. for stdin transform sink makes less sense.. + #todo - default "stack" instead of empty string + set action "" + } + if {[dict exists $args -settings]} { + set logsettings [dict get $args -settings] + } else { + set logsettings {} + } + + set logsettings [dict merge $default_logsettings $logsettings] + set tag [dict get $logsettings -tag] + if {$tag ni $sources} { + lappend sources $tag + } + + set id [shellfilter::stack::add $chan logonly -action $action -settings $logsettings] + return $id + } + + proc ::shellfilter::redir_output_to_log {tagprefix args} { + variable sources + + set default_settings [list -tag ${tagprefix} -syslog "" -file ""] + + set opts [dict create -action "" -settings {}] + set opts [dict merge $opts $args] + set optsettings [dict get $opts -settings] + set settings [dict merge $default_settings $optsettings] + + set tag [dict get $settings -tag] + if {$tag ne $tagprefix} { + error "shellfilter::redir_output_to_log -tag value must match supplied tagprefix:'$tagprefix'. Omit -tag, or make it the same. It will automatically be suffixed with stderr and stdout. Use redir_channel_to_log if you want to separately configure each channel" + } + lappend sources ${tagprefix}stdout ${tagprefix}stderr + + set stdoutsettings $settings + dict set stdoutsettings -tag ${tagprefix}stdout + set stderrsettings $settings + dict set stderrsettings -tag ${tagprefix}stderr + + set idout [redir_channel_to_log stdout -action [dict get $opts -action] -settings $stdoutsettings] + set iderr [redir_channel_to_log stderr -action [dict get $opts -action] -settings $stderrsettings] + + return [list $idout $iderr] + } + + #eg try: set v [list #a b c] + #vs set v {#a b c} + proc list_is_canonical l { + #courtesy DKF via wiki https://wiki.tcl-lang.org/page/BNF+for+Tcl + if {[catch {llength $l}]} {return 0} + string equal $l [list {*}$l] + } + + #return a dict keyed on numerical list index showing info about each element + # - particularly + # 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list + # 'head_tail_chars' to show current first and last character (in case it's wrapped e.g in double or single quotes or an existing set of braces) + proc list_element_info {inputlist} { + set i 0 + set info [dict create] + set testlist [list] + foreach original_item $inputlist { + #--- + # avoid sharing internal rep with original items in the list (avoids shimmering of rep in original list for certain items such as paths) + unset -nocomplain item + append item $original_item {} + #--- + + set iteminfo [dict create] + set itemlen [string length $item] + lappend testlist $item + set tcl_len [string length $testlist] + set diff [expr {$tcl_len - $itemlen}] + if {$diff == 0} { + dict set iteminfo wouldbrace 0 + dict set iteminfo wouldescape 0 + } else { + #test for escaping vs bracing! + set testlistchars [split $testlist ""] + if {([lindex $testlistchars 0] eq "\{") && ([lindex $testlistchars end] eq "\}")} { + dict set iteminfo wouldbrace 1 + dict set iteminfo wouldescape 0 + } else { + dict set iteminfo wouldbrace 0 + dict set iteminfo wouldescape 1 + } + } + set testlist [list] + set charlist [split $item ""] + set char_a [lindex $charlist 0] + set char_b [lindex $charlist 1] + set char_ab ${char_a}${char_b} + set char_y [lindex $charlist end-1] + set char_z [lindex $charlist end] + set char_yz ${char_y}${char_z} + + if { ("{" in $charlist) || ("}" in $charlist) } { + dict set iteminfo has_braces 1 + set innerchars [lrange $charlist 1 end-1] + if {("{" in $innerchars) || ("}" in $innerchars)} { + dict set iteminfo has_inner_braces 1 + } else { + dict set iteminfo has_inner_braces 0 + } + } else { + dict set iteminfo has_braces 0 + dict set iteminfo has_inner_braces 0 + } + + #todo - brace/char counting to determine if actually 'wrapped' + #e.g we could have list element {((abc)} - which appears wrapped if only looking at first and last chars. + #also {(x) (y)} as a list member.. how to treat? + if {$itemlen <= 1} { + dict set iteminfo apparentwrap "not" + } else { + #todo - switch on $char_a$char_z + if {($char_a eq {"}) && ($char_z eq {"})} { + dict set iteminfo apparentwrap "doublequotes" + } elseif {($char_a eq "'") && ($char_z eq "'")} { + dict set iteminfo apparentwrap "singlequotes" + } elseif {($char_a eq "(") && ($char_z eq ")")} { + dict set iteminfo apparentwrap "brackets" + } elseif {($char_a eq "\{") && ($char_z eq "\}")} { + dict set iteminfo apparentwrap "braces" + } elseif {($char_a eq "^") && ($char_z eq "^")} { + dict set iteminfo apparentwrap "carets" + } elseif {($char_a eq "\[") && ($char_z eq "\]")} { + dict set iteminfo apparentwrap "squarebrackets" + } elseif {($char_a eq "`") && ($char_z eq "`")} { + dict set iteminfo apparentwrap "backquotes" + } elseif {($char_a eq "\n") && ($char_z eq "\n")} { + dict set iteminfo apparentwrap "lf-newline" + } elseif {($char_ab eq "\r\n") && ($char_yz eq "\r\n")} { + dict set iteminfo apparentwrap "crlf-newline" + } else { + dict set iteminfo apparentwrap "not-determined" + } + + } + dict set iteminfo wrapbalance "unknown" ;#a hint to caller that apparentwrap is only a guide. todo - possibly make wrapbalance indicate 0 for unbalanced.. and positive numbers for outer-count of wrappings. + #e.g {((x)} == 0 {((x))} == 1 {(x) (y (z))} == 2 + dict set iteminfo head_tail_chars [list $char_a $char_z] + set namemap [list \ + \r cr\ + \n lf\ + {"} doublequote\ + {'} singlequote\ + "`" backquote\ + "^" caret\ + \t tab\ + " " sp\ + "\[" lsquare\ + "\]" rsquare\ + "(" lbracket\ + ")" rbracket\ + "\{" lbrace\ + "\}" rbrace\ + \\ backslash\ + / forwardslash\ + ] + if {[string length $char_a]} { + set char_a_name [string map $namemap $char_a] + } else { + set char_a_name "emptystring" + } + if {[string length $char_z]} { + set char_z_name [string map $namemap $char_z] + } else { + set char_z_name "emptystring" + } + + dict set iteminfo head_tail_names [list $char_a_name $char_z_name] + dict set iteminfo len $itemlen + dict set iteminfo difflen $diff ;#2 for braces, 1 for quoting?, or 0. + dict set info $i $iteminfo + incr i + } + return $info + } + + + #parse bracketed expression (e.g produced by vim "shellxquote=(" ) into a tcl (nested) list + #e.g {(^c:/my spacey/path^ >^somewhere^)} + #e.g {(blah (etc))}" + #Result is always a list - even if only one toplevel set of brackets - so it may need [lindex $result 0] if input is the usual case of {( ...)} + # - because it also supports the perhaps less likely case of: {( ...) unbraced (...)} etc + # Note that + #maintenance warning - duplication in branches for bracketed vs unbracketed! + proc parse_cmd_brackets {str} { + #wordwrappers currently best suited to non-bracket entities - no bracket matching within - anything goes until end-token reached. + # - but.. they only take effect where a word can begin. so a[x y] may be split at the space unless it's within some other wraper e.g " a[x y]" will not break at the space + # todo - consider extending the in-word handling of word_bdepth which is currently only applied to () i.e aaa(x y) is supported but aaa[x y] is not as the space breaks the word up. + set wordwrappers [list \ + "\"" [list "\"" "\"" "\""]\ + {^} [list "\"" "\"" "^"]\ + "'" [list "'" "'" "'"]\ + "\{" [list "\{" "\}" "\}"]\ + {[} [list {[} {]} {]}]\ + ] ;#dict mapping start_character to {replacehead replacetail expectedtail} + set shell_specials [list "|" "|&" "<" "<@" "<<" ">" "2>" ">&" ">>" "2>>" ">>&" ">@" "2>@" "2>@1" ">&@" "&" "&&" ] ;#words/chars that may precede an opening bracket but don't merge with the bracket to form a word. + #puts "pb:$str" + set in_bracket 0 + set in_word 0 + set word "" + set result {} + set word_bdepth 0 + set word_bstack [list] + set wordwrap "" ;#only one active at a time + set bracketed_elements [dict create] + foreach char [split $str ""] { + #puts "c:$char bracketed:$bracketed_elements" + if {$in_bracket > 0} { + if {$in_word} { + if {[string length $wordwrap]} { + #anything goes until end-char + #todo - lookahead and only treat as closing if before a space or ")" ? + lassign [dict get $wordwrappers $wordwrap] _open closing endmark + if {$char eq $endmark} { + set wordwrap "" + append word $closing + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } else { + append word $char + } + } else { + if {$word_bdepth == 0} { + #can potentially close off a word - or start a new one if word-so-far is a shell-special + if {$word in $shell_specials} { + if {$char eq ")"} { + dict lappend bracketed_elements $in_bracket $word + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + set word "" + set in_word 0 + } elseif {[regexp {[\s]} $char]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + incr in_bracket + } else { + #at end of shell-specials is another point to look for word started by a wordwrapper char + #- expect common case of things like >^/my/path^ + if {$char in [dict keys $wordwrappers]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 1 ;#just for explicitness.. we're straight into the next word. + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + #something unusual.. keep going with word! + append word $char + } + } + } else { + + if {$char eq ")"} { + dict lappend bracketed_elements $in_bracket $word + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + set word "" + set in_word 0 + } elseif {[regexp {[\s]} $char]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + #ordinary word up-against and opening bracket - brackets are part of word. + incr word_bdepth + append word "(" + } else { + append word $char + } + } + } else { + #currently only () are used for word_bdepth - todo add all or some wordwrappers chars so that the word_bstack can have multiple active. + switch -- $char { + "(" { + incr word_bdepth + lappend word_bstack $char + append word $char + } + ")" { + incr word_bdepth -1 + set word_bstack [lrange $word_bstack 0 end-1] + append word $char + } + default { + #spaces and chars added to word as it's still in a bracketed section + append word $char + } + } + } + } + } else { + + if {$char eq "("} { + incr in_bracket + + } elseif {$char eq ")"} { + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + } elseif {[regexp {[\s]} $char]} { + # + } else { + #first char of word - look for word-wrappers + if {$char in [dict keys $wordwrappers]} { + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + set word $char + } + set in_word 1 + } + } + } else { + if {$in_word} { + if {[string length $wordwrap]} { + lassign [dict get $wordwrappers $wordwrap] _open closing endmark + if {$char eq $endmark} { + set wordwrap "" + append word $closing + lappend result $word + set word "" + set in_word 0 + } else { + append word $char + } + } else { + + if {$word_bdepth == 0} { + if {$word in $shell_specials} { + if {[regexp {[\s]} $char]} { + lappend result $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + lappend result $word + set word "" + set in_word 0 + incr in_bracket + } else { + #at end of shell-specials is another point to look for word started by a wordwrapper char + #- expect common case of things like >^/my/path^ + if {$char in [dict keys $wordwrappers]} { + lappend result $word + set word "" + set in_word 1 ;#just for explicitness.. we're straight into the next word. + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + #something unusual.. keep going with word! + append word $char + } + } + + } else { + if {[regexp {[\s)]} $char]} { + lappend result $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + incr word_bdepth + append word $char + } else { + append word $char + } + } + } else { + switch -- $char { + "(" { + incr word_bdepth + append word $char + } + ")" { + incr word_bdepth -1 + append word $char + } + default { + append word $char + } + } + } + } + } else { + if {[regexp {[\s]} $char]} { + #insig whitespace(?) + } elseif {$char eq "("} { + incr in_bracket + dict set bracketed_elements $in_bracket [list] + } elseif {$char eq ")"} { + error "unbalanced bracket - unable to proceed result so far: $result bracketed_elements:$bracketed_elements" + } else { + #first char of word - look for word-wrappers + if {$char in [dict keys $wordwrappers]} { + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + set word $char + } + set in_word 1 + } + } + } + #puts "----$bracketed_elements" + } + if {$in_bracket > 0} { + error "shellfilter::parse_cmd_brackets missing close bracket. input was '$str'" + } + if {[dict exists $bracketed_elements 0]} { + #lappend result [lindex [dict get $bracketed_elements 0] 0] + lappend result [dict get $bracketed_elements 0] + } + if {$in_word} { + lappend result $word + } + return $result + } + + #only double quote if argument not quoted with single or double quotes + proc dquote_if_not_quoted {a} { + set wrapchars [string cat [string range $a 0 0] [string range $a end end]] + switch -- $wrapchars { + {""} - {''} { + return $a + } + default { + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + } + } + + #proc dquote_if_not_bracketed/braced? + + #wrap in double quotes if not double-quoted + proc dquote_if_not_dquoted {a} { + set wrapchars [string cat [string range $a 0 0] [string range $a end end]] + switch -- $wrapchars { + {""} { + return $a + } + default { + #escape any inner quotes.. + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + } + } + proc dquote {a} { + #escape any inner quotes.. + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + proc get_scriptrun_from_cmdlist_dquote_if_not {cmdlist {shellcmdflag ""}} { + set scr [auto_execok "script"] + if {[string length $scr]} { + #set scriptrun "( $c1 [lrange $cmdlist 1 end] )" + set arg1 [lindex $cmdlist 0] + if {[string first " " $arg1]>0} { + set c1 [dquote_if_not_quoted $arg1] + #set c1 "\"$arg1\"" + } else { + set c1 $arg1 + } + + if {[string length $shellcmdflag]} { + set scriptrun "$shellcmdflag \$($c1 " + } else { + set scriptrun "\$($c1 " + } + #set scriptrun "$c1 " + foreach a [lrange $cmdlist 1 end] { + #set a [string map [list "/" "//"] $a] + #set a [string map [list "\"" "\\\""] $a] + if {[string first " " $a] > 0} { + append scriptrun [dquote_if_not_quoted $a] + } else { + append scriptrun $a + } + append scriptrun " " + } + set scriptrun [string trim $scriptrun] + append scriptrun ")" + #return [list $scr -q -e -c $scriptrun /dev/null] + return [list $scr -e -c $scriptrun /dev/null] + } else { + return $cmdlist + } + } + + proc ::shellfilter::trun {commandlist args} { + #jmn + } + + + # run a command (or tcl script) with tees applied to stdout/stderr/stdin (or whatever channels are being used) + # By the point run is called - any transforms should already be in place on the channels if they're needed. + # The tees will be inline with none,some or all of those transforms depending on how the stack was configured + # (upstream,downstream configured via -float,-sink etc) + proc ::shellfilter::run {commandlist args} { + #must be a list. If it was a shell commandline string. convert it elsewhere first. + + variable sources + set runtag "shellfilter-run" + #set tid [::shellfilter::log::open $runtag [list -syslog 127.0.0.1:514]] + set tid [::shellfilter::log::open $runtag [list -syslog ""]] + if {[catch {llength $commandlist} listlen]} { + set listlen "" + } + ::shellfilter::log::write $runtag " commandlist:'$commandlist' listlen:$listlen strlen:[string length $commandlist]" + + #flush stdout + #flush stderr + + #adding filters with sink-aside will temporarily disable the existing redirection + #All stderr/stdout from the shellcommand will now tee to the underlying stderr/stdout as well as the configured syslog + + set defaults [dict create \ + -teehandle command \ + -outchan stdout \ + -errchan stderr \ + -inchan stdin \ + -tclscript 0 \ + ] + set opts [dict merge $defaults $args] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set outchan [dict get $opts -outchan] + set errchan [dict get $opts -errchan] + set inchan [dict get $opts -inchan] + set teehandle [dict get $opts -teehandle] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set is_script [dict get $opts -tclscript] + dict unset opts -tclscript ;#don't pass it any further + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set teehandle_out ${teehandle}out ;#default commandout + set teehandle_err ${teehandle}err + set teehandle_in ${teehandle}in + + + #puts stdout "shellfilter initialising tee_to_pipe transforms for in/out/err" + + # sources should be added when stack::new called instead(?) + foreach source [list $teehandle_out $teehandle_err] { + if {$source ni $sources} { + lappend sources $source + } + } + set outdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_out device] + set outpipechan [dict get $outdeviceinfo localchan] + set errdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_err device] + set errpipechan [dict get $errdeviceinfo localchan] + + #set indeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_in device] + #set inpipechan [dict get $indeviceinfo localchan] + + #NOTE:These transforms are not necessarily at the top of each stack! + #The float/sink mechanism, along with whether existing transforms are diversionary decides where they sit. + set id_out [shellfilter::stack::add $outchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_out -pipechan $outpipechan]] + set id_err [shellfilter::stack::add $errchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_err -pipechan $errpipechan]] + + # need to use os level channel handle for stdin - try named pipes (or even sockets) instead of fifo2 for this + # If non os-level channel - the command can't be run with the redirection + # stderr/stdout can be run with non-os handles in the call - + # but then it does introduce issues with terminal-detection and behaviour for stdout at least + # + # input is also a tee - we never want to change the source at this point - just log/process a side-channel of it. + # + #set id_in [shellfilter::stack::add $inchan tee_to_pipe -action sink-aside -settings [list -tag commandin -pipechan $inpipechan]] + + + #set id_out [shellfilter::stack::add stdout tee_to_log -action sink-aside -settings [list -tag shellstdout -syslog 127.0.0.1:514 -file ""]] + #set id_err [shellfilter::stack::add stderr tee_to_log -action sink-aside -settings [list -tag shellstderr -syslog 127.0.0.1:514 -file "stderr.txt"]] + + #we need to catch errors - and ensure stack::remove calls occur. + #An error can be raised if the command couldn't even launch, as opposed to a non-zero exitcode and stderr output from the command itself. + # + if {!$is_script} { + set experiment 0 + if {$experiment} { + try { + set results [exec {*}$commandlist] + set exitinfo [list exitcode 0] + } trap CHILDSTATUS {results options} { + set exitcode [lindex [dict get $options -errorcode] 2] + set exitinfo [list exitcode $exitcode] + } + } else { + if {[catch { + #run process with stdout/stderr/stdin or with configured channels + #set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan $inpipechan {*}$opts] + set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan stdin {*}$opts] + #puts stderr "---->exitinfo $exitinfo" + + #subprocess result should usually have an "exitcode" key + #but for background execution we will get a "pids" key of process ids. + } errMsg]} { + set exitinfo [list error "$errMsg" source shellcommand_stdout_stderr] + } + } + } else { + if {[catch { + #script result + set exitinfo [list result [uplevel #0 [list eval $commandlist]]] + } errMsg]} { + set exitinfo [list error "$errMsg" errorCode $::errorCode errorInfo "$::errorInfo"] + } + } + + + #the previous redirections on the underlying inchan/outchan/errchan items will be restored from the -aside setting during removal + #Remove execution-time Tees from stack + shellfilter::stack::remove stdout $id_out + shellfilter::stack::remove stderr $id_err + #shellfilter::stack::remove stderr $id_in + + + #chan configure stderr -buffering line + #flush stdout + + + ::shellfilter::log::write $runtag " return '$exitinfo'" + ::shellfilter::log::close $runtag + return $exitinfo + } + proc ::shellfilter::logtidyup { {tags {}} } { + variable sources + set worker_errorlist [list] + set tidied_sources [list] + set tidytag "logtidy" + + + # opening a thread or writing to a log/syslog close to possible process exit is probably not a great idea. + # we should ensure the thread already exists early on if we really need logging here. + # + #set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}] + #::shellfilter::log::write $tidytag " logtidyuptags '$tags'" + + foreach s $sources { + if {$s eq $tidytag} { + continue + } + #puts "logtidyup source $s" + set close 1 + if {[llength $tags]} { + if {$s ni $tags} { + set close 0 + } + } + if {$close} { + lappend tidied_sources $s + shellfilter::log::close $s + lappend worker_errorlist {*}[shellthread::manager::get_and_clear_errors $s] + } + } + set remaining_sources [list] + foreach s $sources { + if {$s ni $tidied_sources} { + lappend remaining_sources $s + } + } + + #set sources [concat $remaining_sources $tidytag] + set sources $remaining_sources + + #shellfilter::stack::unwind stdout + #shellfilter::stack::unwind stderr + return [list tidied $tidied_sources errors $worker_errorlist] + } + + #package require tcl::chan::null + # e.g set errchan [tcl::chan::null] + # e.g chan push stdout [shellfilter::chan::var new ::some_var] + proc ::shellfilter::shellcommand_stdout_stderr {commandlist outchan errchan inchan args} { + set valid_flags [list \ + -timeout \ + -outprefix \ + -errprefix \ + -debug \ + -copytempfile \ + -outbuffering \ + -errbuffering \ + -inbuffering \ + -readprocesstranslation \ + -outtranslation \ + -stdinhandler \ + -outchan \ + -errchan \ + -inchan \ + -teehandle\ + ] + + set runtag shellfilter-run2 + #JMN - load from config + #set tid [::shellfilter::log::open $runtag [list -syslog "127.0.0.1:514"]] + set tid [::shellfilter::log::open $runtag [list -syslog ""]] + + if {[llength $args] % 2} { + error "Trailing arguments after any positional arguments must be in pairs of the form -argname argvalue. Valid flags are:'$valid_flags'" + } + set invalid_flags [list] + foreach {k -} $args { + switch -- $k { + -timeout - + -outprefix - + -errprefix - + -debug - + -copytempfile - + -outbuffering - + -errbuffering - + -inbuffering - + -readprocesstranslation - + -outtranslation - + -stdinhandler - + -outchan - + -errchan - + -inchan - + -teehandle { + } + default { + lappend invalid_flags $k + } + } + } + if {[llength $invalid_flags]} { + error "Unknown option(s)'$invalid_flags': must be one of '$valid_flags'" + } + #line buffering generally best for output channels.. keeps relative output order of stdout/stdin closer to source order + #there may be data where line buffering is inappropriate, so it's configurable per std channel + #reading inputs with line buffering can result in extraneous newlines as we can't detect trailing data with no newline before eof. + set defaults [dict create \ + -outchan stdout \ + -errchan stderr \ + -inchan stdin \ + -outbuffering none \ + -errbuffering none \ + -readprocesstranslation auto \ + -outtranslation lf \ + -inbuffering none \ + -timeout 900000\ + -outprefix ""\ + -errprefix ""\ + -debug 0\ + -copytempfile 0\ + -stdinhandler ""\ + ] + + + + set args [dict merge $defaults $args] + set outbuffering [dict get $args -outbuffering] + set errbuffering [dict get $args -errbuffering] + set inbuffering [dict get $args -inbuffering] + set readprocesstranslation [dict get $args -readprocesstranslation] + set outtranslation [dict get $args -outtranslation] + set timeout [dict get $args -timeout] + set outprefix [dict get $args -outprefix] + set errprefix [dict get $args -errprefix] + set debug [dict get $args -debug] + set copytempfile [dict get $args -copytempfile] + set stdinhandler [dict get $args -stdinhandler] + + set debugname "shellfilter-debug" + + if {$debug} { + set tid [::shellfilter::log::open $debugname [list -syslog "127.0.0.1:514"]] + ::shellfilter::log::write $debugname " commandlist '$commandlist'" + } + #'clock micros' good enough id for shellcommand calls unless one day they can somehow be called concurrently or sequentially within a microsecond and within the same interp. + # a simple counter would probably work too + #consider other options if an alternative to the single vwait in this function is used. + set call_id [tcl::clock::microseconds] ; + set ::shellfilter::shellcommandvars($call_id,exitcode) "" + set ::shellfilter::shellcommandvars($call_id,timeoutid) "" + set waitvar ::shellfilter::shellcommandvars($call_id,waitvar) + if {$debug} { + ::shellfilter::log::write $debugname " waitvar '$waitvar'" + } + lassign [chan pipe] rderr wrerr + chan configure $wrerr -blocking 0 + + set custom_stderr "" + set lastitem [lindex $commandlist end] + #todo - ensure we can handle 2> file (space after >) + + #review - reconsider the handling of redirections such that tcl-style are handled totally separately to other shell syntaxes! + # + #note 2>@1 must ocur as last word for tcl - but 2@stdout can occur elsewhere + #(2>@stdout echoes to main stdout - not into pipeline) + #To properly do pipelines it looks like we will have to split on | and call this proc multiple times and wire it up accordingly (presumably in separate threads) + + switch -- [string trim $lastitem] { + {&} { + set name [lindex $commandlist 0] + #background execution - stdout and stderr from child still comes here - but process is backgrounded + #FIX! - this is broken for paths with backslashes for example + #set pidlist [exec {*}[concat $name [lrange $commandlist 1 end]]] + set pidlist [exec {*}$commandlist] + return [list pids $pidlist] + } + {2>&1} - {2>@1} { + set custom_stderr {2>@1} ;#use the tcl style + set commandlist [lrange $commandlist 0 end-1] + } + default { + # 2> filename + # 2>> filename + # 2>@ openfileid + set redir2test [string range $lastitem 0 1] + if {$redir2test eq "2>"} { + set custom_stderr $lastitem + set commandlist [lrange $commandlist 0 end-1] + } + } + } + set lastitem [lindex $commandlist end] + + set teefile "" ;#empty string, write, append + #an ugly hack.. because redirections seem to arrive wrapped - review! + #There be dragons here.. + #Be very careful with list manipulation of the commandlist string.. backslashes cause havoc. commandlist must always be a well-formed list. generally avoid string manipulations on entire list or accidentally breaking a list element into parts if it shouldn't be.. + #The problem here - is that we can't always know what was intended on the commandline regarding quoting + + ::shellfilter::log::write $runtag "checking for redirections in $commandlist" + #sometimes we see a redirection without a following space e.g >C:/somewhere + #normalize + switch -regexp -- $lastitem\ + {^>[/[:alpha:]]+} { + set lastitem "> [string range $lastitem 1 end]" + }\ + {^>>[/[:alpha:]]+} { + set lastitem ">> [string range $lastitem 2 end]" + } + + + #for a redirection, we assume either a 2-element list at tail of form {> {some path maybe with spaces}} + #or that the tail redirection is not wrapped.. x y z > {some path maybe with spaces} + #we can't use list methods such as llenth on a member of commandlist + set wordlike_parts [regexp -inline -all {\S+} $lastitem] + + if {([llength $wordlike_parts] >= 2) && ([lindex $wordlike_parts 0] in [list ">>" ">"])} { + #wrapped redirection - but maybe not 'well' wrapped (unquoted filename) + set lastitem [string trim $lastitem] ;#we often see { > something} + + #don't use lassign or lrange on the element itself without checking first + #we can treat the commandlist as a whole as a well formed list but not neccessarily each element within. + #lassign $lastitem redir redirtarget + #set commandlist [lrange $commandlist 0 end-1] + # + set itemchars [split $lastitem ""] + set firstchar [lindex $itemchars 0] + set lastchar [lindex $itemchars end] + + #NAIVE test for double quoted only! + #consider for example {"a" x="b"} + #testing first and last is not decisive + #We need to decide what level of drilling down is even appropriate here.. + #if something was double wrapped - it was perhaps deliberate so we don't interpret it as something(?) + set head_tail_chars [list $firstchar $lastchar] + set doublequoted [expr {[llength [lsearch -all $head_tail_chars "\""]] == 2}] + if {[string equal "\{" $firstchar] && [string equal "\}" $lastchar]} { + set curlyquoted 1 + } else { + set curlyquoted 0 + } + + if {$curlyquoted} { + #these are not the tcl protection brackets but ones supplied in the argument + #it's still not valid to use list operations on a member of the commandlist + set inner [string range $lastitem 1 end-1] + #todo - fix! we still must assume there could be list-breaking data! + set innerwords [regexp -inline -all {\S+} $inner] ;#better than [split $inner] because we don't get extra empty elements for each whitespace char + set redir [lindex $innerwords 0] ;#a *potential* redir - to be tested below + set redirtarget [lrange $innerwords 1 end] ;#all the rest + } elseif {$doublequoted} { + ::shellfilter::log::write $debugname "doublequoting at tail of command '$commandlist'" + set inner [string range $lastitem 1 end-1] + set innerwords [regexp -inline -all {\S+} $inner] + set redir [lindex $innerwords 0] + set redirtarget [lrange $innerwords 1 end] + } else { + set itemwords [regexp -inline -all {\S+} $lastitem] + # e.g > c:\test becomes > {c:\test} + # but > c/mnt/c/test/temp.txt stays as > /mnt/c/test/temp.txt + set redir [lindex $itemwords 0] + set redirtarget [lrange $itemwords 1 end] + } + set commandlist [lrange $commandlist 0 end-1] + + } elseif {[lindex $commandlist end-1] in [list ">>" ">"]} { + #unwrapped redirection + #we should be able to use list operations like lindex and lrange here as the command itself is hopefully still a well formed list + set redir [lindex $commandlist end-1] + set redirtarget [lindex $commandlist end] + set commandlist [lrange $commandlist 0 end-2] + } else { + #no redirection + set redir "" + set redirtarget "" + #no change to command list + } + + + switch -- $redir { + ">>" - ">" { + set redirtarget [string trim $redirtarget "\""] + ::shellfilter::log::write $runtag " have redirection '$redir' to '$redirtarget'" + + set winfile $redirtarget ;#default assumption + switch -glob -- $redirtarget { + "/c/*" { + set winfile "c:/[string range $redirtarget 3 end]" + } + "/mnt/c/*" { + set winfile "c:/[string range $redirtarget 7 end]" + } + } + + if {[file exists [file dirname $winfile]]} { + #containing folder for target exists + if {$redir eq ">"} { + set teefile "write" + } else { + set teefile "append" + } + ::shellfilter::log::write $runtag "Directory exists '[file dirname $winfile]' operation:$teefile" + } else { + #we should be writing to a file.. but can't + ::shellfilter::log::write $runtag "cannot verify directory exists '[file dirname $winfile]'" + } + } + default { + ::shellfilter::log::write $runtag "No redir found!!" + } + } + + #often first element of command list is wrapped and cannot be run directly + #e.g {{ls -l} {> {temp.tmp}}} + #we will assume that if there is a single element which is a pathname containing a space - it is doubly wrapped. + # this may not be true - and the command may fail if it's just {c:\program files\etc} but it is the less common case and we currently have no way to detect. + #unwrap first element.. will not affect if not wrapped anyway (subject to comment above re spaces) + set commandlist [concat [lindex $commandlist 0] [lrange $commandlist 1 end]] + + #todo? + #child process environment. + # - to pass a different environment to the child - we would need to save the env array, modify as required, and then restore the env array. + + #to restore buffering states after run + set remember_in_out_err_buffering [list \ + [chan configure $inchan -buffering] \ + [chan configure $outchan -buffering] \ + [chan configure $errchan -buffering] \ + ] + + set remember_in_out_err_translation [list \ + [chan configure $inchan -translation] \ + [chan configure $outchan -translation] \ + [chan configure $errchan -translation] \ + ] + + + + + #chan configure $inchan -buffering none -blocking 1 ;#test + chan configure $inchan -buffering $inbuffering -blocking 0 ;#we are setting up a readable handler for this - so non-blocking ok + + + chan configure $errchan -buffering $errbuffering + #chan configure $outchan -blocking 0 + chan configure $outchan -buffering $outbuffering ;#don't configure non-blocking. weird duplicate of *second* line occurs if you do. + # + + #-------------------------------------------- + #Tested on windows. Works to stop in output when buffering is none, reading from channel with -translation auto + #cmd, pwsh, tcl + #chan configure $outchan -translation lf + #chan configure $errchan -translation lf + #-------------------------------------------- + chan configure $outchan -translation $outtranslation + chan configure $errchan -translation $outtranslation + + #puts stderr "chan configure $wrerr [chan configure $wrerr]" + if {$debug} { + ::shellfilter::log::write $debugname "COMMAND [list $commandlist] strlen:[string length $commandlist] llen:[llength $commandlist]" + } + #todo - handle custom redirection of stderr to a file? + if {[string length $custom_stderr]} { + #::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist $custom_stderr] a+" + #set rdout [open |[concat $commandlist $custom_stderr] a+] + ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list $custom_stderr <@$inchan]] [list RDONLY]" + set rdout [open |[concat $commandlist [list <@$inchan $custom_stderr]] [list RDONLY]] + set rderr "bogus" ;#so we don't wait for it + } else { + ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]" + #set rdout [open |[concat $commandlist [list 2>@$wrerr]] a+] + #set rdout [open |[concat $commandlist [list 2>@$wrerr]] [list RDWR]] + + # If we don't redirect stderr to our own tcl-based channel - then the transforms don't get applied. + # This is the whole reason we need these file-event loops. + # Ideally we need something like exec,open in tcl that interacts with transformed channels directly and emits as it runs, not only at termination + # - and that at least appears like a terminal to the called command. + #set rdout [open |[concat $commandlist [list 2>@stderr <@$inchan]] [list RDONLY]] + + #REVIEW! + #if the child process takes a while to begin reading stdin - the data on stdin between when we stopped the parent chan event handler and when the child gets data, + #seems to stay buffered somewhere. It is then read by the parent, after the child returns. (ie not lost, but out-of-order) + #This can be apparent sometimes even with fast typing upon calling an executable. (e.g occasionally even vim - but seems to be timing based so might only happen first time if at all) + # see scriptlib/stdin_race.tcl etc test files. + #similar problem with python & perl - issue seems to be in libc or OS buffering behaviour for standard channels. + #note that zig (repo/jn/zig/stdin_race) seems to avoid this issue - todo - make zig based binary extension for open/exec? + + set rdout [open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]] + + chan configure $rderr -buffering $errbuffering -blocking 0 + chan configure $rderr -translation $readprocesstranslation + } + + + + set command_pids [pid $rdout] + #puts stderr "command_pids: $command_pids" + #tcl::process ensemble only available in 8.7+ - and it didn't prove useful here anyway + # the child process generally won't shut down until channels are closed. + # premature EOF on grandchild process launch seems to be due to lack of terminal emulation when redirecting stdin/stdout. + # worked around in punk/repl using 'script' command as a fake tty. + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $command_pids 0] ni $subprocesses} { + # puts stderr "pid [lindex $command_pids 0] not running $errMsg" + #} else { + # puts stderr "pid [lindex $command_pids 0] is running" + #} + + + if {$debug} { + ::shellfilter::log::write $debugname "pipeline pids: $command_pids" + } + + #jjj + + + chan configure $rdout -buffering $outbuffering -blocking 0 + chan configure $rdout -translation $readprocesstranslation + + if {![string length $custom_stderr]} { + chan event $rderr readable [list apply {{chan other wrerr outchan errchan waitfor errprefix errbuffering debug debugname pids} { + if {$errbuffering eq "line"} { + set countchunk [chan gets $chan chunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + #errprefix only applicable to line buffered output + if {$countchunk >= 0} { + if {[chan eof $chan]} { + puts -nonewline $errchan ${errprefix}$chunk + } else { + puts $errchan "${errprefix}$chunk" + } + } + } else { + set chunk [chan read $chan] + if {[string length $chunk]} { + puts -nonewline $errchan $chunk + } + } + if {[chan eof $chan]} { + flush $errchan ;#jmn + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $pids 0] ni $subprocesses} { + # puts stderr "stderr reader: pid [lindex $pids 0] no longer running" + #} else { + # puts stderr "stderr reader: pid [lindex $pids 0] still running" + #} + chan close $chan + #catch {chan close $wrerr} + #if {$other ni [chan names]} { + # set $waitfor stderr + #} + if {[catch {chan configure $other}]} { + set $waitfor stderr + } + } + }} $rderr $rdout $wrerr $outchan $errchan $waitvar $errprefix $errbuffering $debug $debugname $command_pids] + } + + #todo - handle case where large amount of stdin coming in faster than rdout can handle + #as is - arbitrary amount of memory could be used because we aren't using a filevent for rdout being writable + # - we're just pumping it in to the non-blocking rdout buffers + # ie there is no backpressure and stdin will suck in as fast as possible. + # for most commandlines this probably isn't too big a deal.. but it could be a problem for multi-GB disk images etc + # + # + + ## Note - detecting trailing missing nl before eof is basically the same here as when reading rdout from executable + # - but there is a slight difference in that with rdout we get an extra blocked state just prior to the final read. + # Not known if that is significant + ## with inchan configured -buffering line + #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl -r cat + #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl -r cat + #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:1 pend:-1 count:3 + #etc + + if 0 { + chan event $inchan readable [list apply {{chan wrchan inbuffering waitfor} { + #chan copy stdin $chan ;#doesn't work in a chan event + if {$inbuffering eq "line"} { + set countchunk [chan gets $chan chunk] + #puts $wrchan "stdinstate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + if {$countchunk >= 0} { + if {[chan eof $chan]} { + puts -nonewline $wrchan $chunk + } else { + puts $wrchan $chunk + } + } + } else { + set chunk [chan read $chan] + if {[string length $chunk]} { + puts -nonewline $wrchan $chunk + } + } + if {[chan eof $chan]} { + puts stderr "|stdin_reader>eof [chan configure stdin]" + chan event $chan readable {} + #chan close $chan + chan close $wrchan write ;#half close + #set $waitfor "stdin" + } + }} $inchan $rdout $inbuffering $waitvar] + + if {[string length $stdinhandler]} { + chan configure stdin -buffering line -blocking 0 + chan event stdin readable $stdinhandler + } + } + + set actual_proc_out_buffering [chan configure $rdout -buffering] + set actual_outchan_buffering [chan configure $outchan -buffering] + #despite whatever is configured - we match our reading to how we need to output + set read_proc_out_buffering $actual_outchan_buffering + + + + if {[string length $teefile]} { + set logname "redir_[string map {: _} $winfile]_[tcl::clock::microseconds]" + set tid [::shellfilter::log::open $logname {-syslog 127.0.0.1:514}] + if {$teefile eq "write"} { + ::shellfilter::log::write $logname "opening '$winfile' for write" + set fd [open $winfile w] + } else { + ::shellfilter::log::write $logname "opening '$winfile' for appending" + set fd [open $winfile a] + } + #chan configure $fd -translation lf + chan configure $fd -translation $outtranslation + chan configure $fd -encoding utf-8 + + set tempvar_bytetotal [namespace current]::totalbytes[tcl::clock::microseconds] + set $tempvar_bytetotal 0 + chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname writefile writefilefd copytempfile bytevar logtag} { + #review - if we write outprefix to normal stdout.. why not to redirected file? + #usefulness of outprefix is dubious + upvar $bytevar totalbytes + if {$read_proc_out_buffering eq "line"} { + #set outchunk [chan read $chan] + set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + if {$countchunk >= 0} { + if {![chan eof $chan]} { + set numbytes [expr {[string length $outchunk] + 1}] ;#we are assuming \n not \r\n - but count won't/can't be completely accurate(?) - review + puts $writefilefd $outchunk + } else { + set numbytes [string length $outchunk] + puts -nonewline $writefilefd $outchunk + } + incr totalbytes $numbytes + ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" + #puts $outchan "${outprefix} wrote $numbytes bytes to $writefile" + } + } else { + set outchunk [chan read $chan] + if {[string length $outchunk]} { + puts -nonewline $writefilefd $outchunk + set numbytes [string length $outchunk] + incr totalbytes $numbytes + ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" + } + } + if {[chan eof $chan]} { + flush $writefilefd ;#jmn + #set blocking so we can get exit code + chan configure $chan -blocking 1 + catch {::shellfilter::log::write $logtag "${outprefix} total bytes $totalbytes written to $writefile"} + #puts $outchan "${outprefix} total bytes $totalbytes written to $writefile" + catch {close $writefilefd} + if {$copytempfile} { + catch {file copy $writefile "[file rootname $writefile]_copy[file extension $writefile]"} + } + try { + chan close $chan + set ::shellfilter::shellcommandvars($call_id,exitcode) 0 + if {$debug} { + ::shellfilter::log::write $debugname "(teefile) -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + if {$debug} { + ::shellfilter::log::write $debugname "(teefile) CHILD PROCESS EXITED with code: $code" + } + set ::shellfilter::shellcommandvars($call_id,exitcode) $code + } + catch {chan close $wrerr} + #if {$other ni [chan names]} { + # set $waitfor stdout + #} + if {[catch {chan configure $other}]} { + set $waitfor stdout + } + } + }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $winfile $fd $copytempfile $tempvar_bytetotal $logname] + + } else { + + # This occurs when we have outbuffering set to 'line' - as the 'input' from rdout which comes from the executable is also configured to 'line' + # where b:0|1 is whether chan blocked $chan returns 0 or 1 + # pend is the result of chan pending $chan + # eof is the resot of chan eof $chan + + + ##------------------------- + ##If we still read with gets,to retrieve line by line for output to line-buffered output - but the input channel is configured with -buffering none + ## then we can detect the difference + # there is an extra blocking read - but we can stil use eof with data to detect the absent newline and avoid passing an extra one on. + #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /u/c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:1 eof:0 pend:-1 count:-1 + #instate b:0 eof:1 pend:-1 count:3 + #etc + ##------------------------ + + + #this should only occur if upstream is coming from stdin reader that has line buffering and hasn't handled the difference properly.. + ###reading with gets from line buffered input with trailing newline + #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + ###reading with gets from line buffered input with trailing newline + ##No detectable difference! + #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + ##------------------------- + + #Note that reading from -buffering none and writing straight out gives no problem because we pass the newlines through as is + + + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($rdout) 0 ;#a very specific case of readblocked prior to eof.. possibly not important + #this detection is disabled for now - but left for debugging in case it means something.. or changes + chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname pids} { + #set outchunk [chan read $chan] + + if {$read_proc_out_buffering eq "line"} { + set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + #countchunk can be -1 before eof e.g when blocked + #debugging output inline with data - don't leave enabled + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + if {$countchunk >= 0} { + if {![chan eof $chan]} { + puts $outchan ${outprefix}$outchunk + } else { + puts -nonewline $outchan ${outprefix}$outchunk + #if {$::shellfilter::chan::lastreadblocked_nodata_noeof($chan)} { + # seems to be the usual case + #} else { + # #false alarm, or ? we've reached eof with data but didn't get an empty blocking read just prior + # #Not known if this occurs + # #debugging output inline with data - don't leave enabled + # puts $outchan "!!!prev read didn't block: instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + #} + } + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) 0 + } else { + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) [expr {[chan blocked $chan] && ![chan eof $chan]}] + } + } else { + #puts $outchan "read CHANNEL $chan [chan configure $chan]" + #puts $outchan "write CHANNEL $outchan b:[chan configure $outchan -buffering] t:[chan configure $outchan -translation] e:[chan configure $outchan -encoding]" + set outchunk [chan read $chan] + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:[string length $outchunk]" + if {[string length $outchunk]} { + #set stringrep [encoding convertfrom utf-8 $outchunk] + #set newbytes [encoding convertto utf-16 $stringrep] + #puts -nonewline $outchan $newbytes + puts -nonewline $outchan $outchunk + } + } + + if {[chan eof $chan]} { + flush $outchan ;#jmn + #for now just look for first element in the pid list.. + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $pids 0] ni $subprocesses} { + # puts stderr "stdout reader pid: [lindex $pids 0] no longer running" + #} else { + # puts stderr "stdout reader pid: [lindex $pids 0] still running" + #} + + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan]" + chan configure $chan -blocking 1 ;#so we can get exit code + try { + chan close $chan + set ::shellfilter::shellcommandvars($call_id,exitcode) 0 + if {$debug} { + ::shellfilter::log::write $debugname " -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + set ::shellfilter::shellcommandvars($call_id,exitcode) $code + if {$debug} { + ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with code: $code" + } + } trap CHILDKILLED {result options} { + #set code [lindex [dict get $options -errorcode] 2] + #set ::shellfilter::shellcommandvars(%id%,exitcode) $code + set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled" + if {$debug} { + ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with result:'$result' options:'$options'" + } + + } finally { + #puts stdout "HERE" + #flush stdout + + } + catch {chan close $wrerr} + #if {$other ni [chan names]} { + # set $waitfor stdout + #} + if {[catch {chan configure $other}]} { + set $waitfor stdout + } + + } + }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $command_pids] + } + + #todo - add ability to detect activity/data-flow and change timeout to only apply for period with zero data + #e.g x hrs with no data(?) + #reset timeout when data detected. + #review - stdin??? + set ::shellfilter::shellcommandvars($call_id,timeoutid) [after $timeout [string map [list %cpids% $command_pids %w% $waitvar %id% $call_id %wrerr% $wrerr %rdout% $rdout %rderr% $rderr %debug% $debug %debugname% $debugname] { + if {[info exists ::shellfilter::shellcommandvars(%id%,exitcode)]} { + #killing the task (on windows) doesn't seem to work if done after we close the output channels + catch {puts stderr "timeout - closing.";flush stderr} + set command_pids "{%cpids%}" + if {[llength $command_pids]} { + set pid [lindex $command_pids 0] + if {$::tcl_platform(platform) eq "windows"} { + set killcmd [list [auto_execok taskkill] /F /PID $pid] + } else { + #set killcmd [list kill -9 $pid] + set killcmd [list kill -TERM $pid] + } + if {[catch { + exec {*}$killcmd + } errM]} { + puts stderr "Failed to kill '$pid': errMsg $errM" + flush stderr + } + } + if {[set ::shellfilter::shellcommandvars(%id%,exitcode)] ne ""} { + catch { chan close %wrerr% } + catch { chan close %rdout%} + catch { chan close %rderr%} + } else { + chan configure %rdout% -blocking 1 + try { + chan close %rdout% + set ::shellfilter::shellcommandvars(%id%,exitcode) 0 + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) CHILD PROCESS EXITED with code: $code" + } + set ::shellfilter::shellcommandvars(%id%,exitcode) $code + } trap CHILDKILLED {result options} { + set code [lindex [dict get $options -errorcode] 2] + #set code [dict get $options -code] + #set ::shellfilter::shellcommandvars(%id%,exitcode) $code + #set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled-timeout" + set ::shellfilter::shellcommandvars(%id%,exitcode) "childkilled-timeout" + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) CHILDKILLED with code: $code" + ::shellfilter::log::write %debugname% "(timeout) result:$result options:$options" + } + + } + catch { chan close %wrerr% } + catch { chan close %rderr%} + } + set %w% "timeout" + } + }]] + + + vwait $waitvar + after cancel $::shellfilter::shellcommandvars($call_id,timeoutid) + + #puts stderr "waitvar:[set $waitvar]" + #flush stderr + #if {[set $waitvar] eq "timeout"} { + # #note: attempting to kill a process here (after channels closed) doesn't work (on windows at least) + # puts stderr "command_pids: $command_pids" + # flush stderr + #} + + set exitcode [set ::shellfilter::shellcommandvars($call_id,exitcode)] + if {![string is digit -strict $exitcode]} { + puts stderr "Process exited with non-numeric code: $exitcode closed_by:[set $waitvar]" + flush stderr + } + if {[string length $teefile]} { + #cannot be called from within an event handler above.. vwait reentrancy etc + catch {::shellfilter::log::close $logname} + } + + if {$debug} { + ::shellfilter::log::write $debugname " closed by: [set $waitvar] with exitcode: $exitcode" + catch {::shellfilter::log::close $debugname} + } + array unset ::shellfilter::shellcommandvars $call_id,* + + + #restore buffering to pre shellfilter::run state + lassign $remember_in_out_err_buffering bin bout berr + chan configure $inchan -buffering $bin + chan configure $outchan -buffering $bout + chan configure $errchan -buffering $berr + + lassign $remember_in_out_err_translation tin tout terr + chan configure $inchan -translation $tin + chan configure $outchan -translation $tout + chan configure $errchan -translation $terr + + + #in channel probably closed..(? review - should it be?) + catch { + chan configure $inchan -buffering $bin + } + + + return [list exitcode $exitcode] + } + +} + +package provide shellfilter [namespace eval shellfilter { + variable version + set version 0.2.1 +}] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm index 3071ebd3..d776aba3 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm @@ -11069,8 +11069,8 @@ tcl::namespace::eval punk::args::argdocbase { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::args::package { variable PUNKARGS + # @dynamic not required? lappend PUNKARGS [list { - @dynamic @id -id "::punk::args::package::standard_about" @cmd -name "%pkg%::about" -help\ "About %pkg% diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix-0.2.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix-0.2.1.tm index 63cf0427..276a3fc3 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix-0.2.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix-0.2.1.tm @@ -20,6 +20,7 @@ tcl::namespace::eval punk::mix { } errTemplates]} { #emit a warning - but continue on without templates anyway. (punk::mix required to load when using bootsupport paths) puts stderr "punk::mix failed to load ZIP archive-based module punk::mix::templates\nUse a modern Tcl with zipfs, or a recent vfs::zip library\nError:$errTemplates" + puts stderr "Unable to register any template providers - continuing anyway" } else { set t [time { if {[catch {punk::mix::templates::provider register *} errM]} { @@ -29,8 +30,8 @@ tcl::namespace::eval punk::mix { puts stderr $::errorInfo } }] + puts stderr "->punk::mix::templates::provider register * t=$t" } - puts stderr "->punk::mix::templates::provider register * t=$t" } init } diff --git a/src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.1.tm b/src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.1.tm new file mode 100644 index 00000000..7b1098f3 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.1.tm @@ -0,0 +1,3348 @@ +#copyright 2023 Julian Marcel Noble +#license: BSD (revised 3-clause) +# +#Note shellfilter is currently only directly useful for unidirectional channels e.g stdin,stderr,stdout, or for example fifo2 where only one direction is being used. +#To generalize this to bidrectional channels would require shifting around read & write methods on transform objects in a very complicated manner. +#e.g each transform would probably be a generic transform container which holds sub-objects to which read & write are indirected. +#This is left as a future exercise...possibly it's best left as a concept for uni-directional channels anyway +# - as presumably the reads/writes from a bidirectional channel could be diverted off to unidirectional pipelines for processing with less work +# (and maybe even better speed/efficiency if the data volume is asymmetrical and there is significant processing on one direction) +# + + +tcl::namespace::eval shellfilter::log { + variable allow_adhoc_tags 1 + variable open_logs [tcl::dict::create] + variable is_enabled 0 + + proc disable {} { + variable is_enabled + set is_enabled 0 + proc ::shellfilter::log::open {tag settingsdict} {} + proc ::shellfilter::log::write {tag msg} {} + proc ::shellfilter::log::write_sync {tag msg} {} + proc ::shellfilter::log::close {tag} {} + } + + proc enable {} { + variable is_enabled + set is_enabled 1 + #'tag' is an identifier for the log source. + # each tag will use it's own thread to write to the configured log target + proc ::shellfilter::log::open {tag {settingsdict {}}} { + upvar ::shellfilter::sources sourcelist + if {![dict exists $settingsdict -tag]} { + tcl::dict::set settingsdict -tag $tag + } else { + #review + if {$tag ne [tcl::dict::get $settingsdict -tag]} { + error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" + } + } + if {$tag ni $sourcelist} { + lappend sourcelist $tag + } + + #note new_worker + set worker_tid [shellthread::manager::new_worker $tag $settingsdict] + #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" + return $worker_tid + } + proc ::shellfilter::log::write {tag msg} { + upvar ::shellfilter::sources sourcelist + variable allow_adhoc_tags + if {!$allow_adhoc_tags} { + if {$tag ni $sourcelist} { + error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag , and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags" + } + } + shellthread::manager::write_log $tag $msg + } + #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written + proc ::shellfilter::log::write_sync {tag msg} { + shellthread::manager::write_log $tag $msg -async 0 + } + proc ::shellfilter::log::close {tag} { + #shellthread::manager::close_worker $tag + shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed + } + + } + + #review + #configure whether we can call shellfilter::log::write without having called open first + proc require_open {{is_open_required {}}} { + variable allow_adhoc_tags + if {![string length $is_open_required]} { + return $allow_adhoc_tags + } else { + #why not use string is boolean? + set truevalues [list y yes true 1] + set falsevalues [list n no false 0] + if {[string tolower $is_open_required] in $truevalues} { + set allow_adhoc_tags 1 + } elseif {[string tolower $is_open_required] in $falsevalues} { + set allow_adhoc_tags 0 + } else { + error "shellfilter::log::require_open unrecognised value '$is_open_required' try one of $truevalues or $falsevalues" + } + } + } + if {[catch {package require shellthread}]} { + shellfilter::log::disable + } else { + shellfilter::log::enable + } + +} +namespace eval shellfilter::pipe { + #write channel for program. workerthread reads other end of fifo2 and writes data somewhere + proc open_out {tag_pipename {pipesettingsdict {}}} { + set defaultsettings {-buffering full} + set settingsdict [dict merge $defaultsettings $pipesettingsdict] + package require shellthread + #we are only using the fifo in a single direction to pipe to another thread + # - so whilst wchan and rchan could theoretically each be both read & write we're only using them for one operation each + if {![catch {package require Memchan}]} { + lassign [fifo2] wchan rchan + } else { + package require tcl::chan::fifo2 + lassign [tcl::chan::fifo2] wchan rchan + } + #default -translation for both types of fifo on windows is {auto crlf} + # -encoding is as per '[encoding system]' on the platform - e.g utf-8 (e.g windows when beta-utf8 enabled) + chan configure $wchan -buffering [dict get $settingsdict -buffering] ;# + #application end must not be binary for our filters to operate on it + + + #chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation binary ;#works reasonably.. + chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation lf + + set worker_tid [shellthread::manager::new_pipe_worker $tag_pipename $settingsdict] + #puts stderr "worker_tid: $worker_tid" + + #set_read_pipe does the thread::transfer of the rchan end. -buffering setting is maintained during thread transfer + shellthread::manager::set_pipe_read_from_client $tag_pipename $worker_tid $rchan + + set pipeinfo [list localchan $wchan remotechan $rchan workertid $worker_tid direction out] + return $pipeinfo + } + + #read channel for program. workerthread writes to other end of fifo2 from whereever it's reading (stdin, file?) + proc open_in {tag_pipename {settingsdict {} }} { + package require shellthread + package require tcl::chan::fifo2 + lassign [tcl::chan::fifo2] wchan rchan + set program_chan $rchan + set worker_chan $wchan + chan configure $worker_chan -buffering [dict get $settingsdict -buffering] + chan configure $program_chan -buffering [dict get $settingsdict -buffering] + + chan configure $program_chan -blocking 0 + chan configure $worker_chan -blocking 0 + set worker_tid [shellthread::manager::new_worker $tag_pipename $settingsdict] + + shellthread::manager::set_pipe_write_to_client $tag_pipename $worker_tid $worker_chan + + set pipeinfo [list localchan $program_chan remotechan $worker_chan workertid $worker_tid direction in] + puts stderr "|jn>pipe::open_in returning $pipeinfo" + puts stderr "program_chan: [chan conf $program_chan]" + return $pipeinfo + } + +} + + +namespace eval shellfilter::chan { + set testobj ::shellfilter::chan::var + if {$testobj ni [info commands $testobj]} { + + oo::class create var { + variable o_datavar + variable o_trecord + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + set varname [dict get $settingsdict -varname] + set o_datavar $varname + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 1 ;# as a var is diversionary - default it to be a jucntion + } + } + method initialize {ch mode} { + return [list initialize finalize write] + } + method finalize {ch} { + my destroy + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {ch count} { + # return ? + #} + method write {ch bytes} { + set stringdata [encoding convertfrom $o_enc $bytes] + append $o_datavar $stringdata + return "" + } + method meta_is_redirection {} { + return $o_is_junction + } + method meta_buffering_supported {} { + return [list line full none] + } + } + + #todo - something similar for multiple grep specs each with own -pre & -post .. store to dict? + oo::class create tee_grep_to_var { + variable o_datavar + variable o_lastxlines + variable o_trecord + variable o_grepfor + variable o_prelines + variable o_postlines + variable o_postcountdown + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_lastxlines [list] + set o_postcountdown 0 + set defaults [tcl::dict::create -pre 1 -post 1] + set settingsdict [tcl::dict::get $tf -settings] + set settings [tcl::dict::merge $defaults $settingsdict] + set o_datavar [tcl::dict::get $settings -varname] + set o_grepfor [tcl::dict::get $settings -grep] + set o_prelines [tcl::dict::get $settings -pre] + set o_postlines [tcl::dict::get $settings -post] + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize finalize write] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #method read {transform_handle count} { + # return ? + #} + method write {transform_handle bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set lastx $o_lastxlines + lappend o_lastxlines $logdata + + if {$o_postcountdown > 0} { + append $o_datavar $logdata + if {[regexp $o_grepfor $logdata]} { + #another match in postlines + set o_postcountdown $o_postlines + } else { + incr o_postcountdown -1 + } + } else { + if {[regexp $o_grepfor $logdata]} { + append $o_datavar [join $lastx] + append $o_datavar $logdata + set o_postcountdown $o_postlines + } + } + + if {[llength $o_lastxlines] > $o_prelines} { + set o_lastxlines [lrange $o_lastxlines 1 end] + } + return $bytes + } + method meta_is_redirection {} { + return $o_is_junction + } + method meta_buffering_supported {} { + return [list line] + } + } + + oo::class create tee_to_var { + variable o_datavars + variable o_trecord + variable o_enc + variable o_encbuf + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_encbuf "" + set settingsdict [tcl::dict::get $tf -settings] + set varname [tcl::dict::get $settingsdict -varname] + set o_datavars $varname + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {ch mode} { + return [list initialize finalize write flush clear] + } + method finalize {ch} { + my destroy + } + method clear {ch} { + return + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {ch count} { + # return ? + #} + #method flush {ch} { + # return "" + #} + method flush {transform_handle} { + #puts stdout "" + #review - just clear o_encbuf and emit nothing? + #we wouldn't have a value there if it was convertable from the channel encoding? + set clear $o_encbuf + set o_encbuf "" + return $o_encbuf + } + method write {ch bytes} { + #test with set x [string repeat " \U1f6c8" 2043] + #or + #test with set x [string repeat " \U1f6c8" 683] + #most windows terminals (at least) may emit two unrecognised chars "??" at the end + + #Our goal with the while loop here is to avoid encoding conversion errors + #the source of the bogus chars in terminals is unclear. + #Alacritty on windows doesn't seem to have the problem, but wezterm,cmd,windows terminal do. + + #set stringdata [tcl::encoding::convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [string length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [string range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + + foreach v $o_datavars { + append $v $stringdata + } + #return $bytes + return [string range $inputbytes 0 end-$tail_offset] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + oo::class create tee_to_pipe { + variable o_logsource + variable o_localchan + variable o_enc + variable o_encbuf + variable o_trecord + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_encbuf "" + set settingsdict [tcl::dict::get $tf -settings] + if {![dict exists $settingsdict -tag]} { + error "tee_to_pipe constructor settingsdict missing -tag" + } + set o_localchan [tcl::dict::get $settingsdict -pipechan] + set o_logsource [tcl::dict::get $settingsdict -tag] + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize read drain write flush clear finalize] + } + method finalize {transform_handle} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {transform_handle events} { + # must be present but we ignore it because we do not + # post any events + } + method clear {transform_handle} { + return + } + method drain {transform_handle} { + return "" + } + method read {transform_handle bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + #::shellfilter::log::write $o_logsource $logdata + puts -nonewline $o_localchan $logdata + return $bytes + } + method flush {transform_handle} { + #return "" + set clear $o_encbuf + set o_encbuf "" + return $o_encbuf + } + method write {transform_handle bytes} { + #set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + #::shellfilter::log::write $o_logsource $logdata + puts -nonewline $o_localchan $stringdata + #return $bytes + return [::tcl::string::range $inputbytes 0 end-$tail_offset] + } + #a tee is not a redirection - because data still flows along the main path + method meta_is_redirection {} { + return $o_is_junction + } + + } + oo::class create tee_to_log { + variable o_tid + variable o_logsource + variable o_trecord + variable o_enc + variable o_encbuf + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_encbuf "" + set settingsdict [tcl::dict::get $tf -settings] + if {![tcl::dict::exists $settingsdict -tag]} { + error "tee_to_log constructor settingsdict missing -tag" + } + set o_logsource [tcl::dict::get $settingsdict -tag] + set o_tid [::shellfilter::log::open $o_logsource $settingsdict] + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {ch mode} { + return [list initialize read write flush finalize] + } + method finalize {ch} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + method read {ch bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + ::shellfilter::log::write $o_logsource $logdata + return $bytes + } + method flush {transform_handle} { + #return "" + set clear $o_encbuf + set o_encbuf "" + return $o_encbuf + } + method write {ch bytes} { + #set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + set bytes [::tcl::string::range $inputbytes 0 end-$tail_offset] + ::shellfilter::log::write $o_logsource $stringdata + return $bytes + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + + oo::class create logonly { + variable o_tid + variable o_logsource + variable o_trecord + variable o_enc + variable o_encbuf + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set o_encbuf "" + set settingsdict [dict get $tf -settings] + if {![dict exists $settingsdict -tag]} { + error "logonly constructor settingsdict missing -tag" + } + set o_logsource [dict get $settingsdict -tag] + set o_tid [::shellfilter::log::open $o_logsource $settingsdict] + } + method initialize {transform_handle mode} { + return [list initialize finalize write] + } + method finalize {transform_handle} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {transform_handle events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {transform_handle count} { + # return ? + #} + method write {transform_handle bytes} { + #set logdata [encoding convertfrom $o_enc $bytes] + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return + } + } + + #::shellfilter::log::write_sync $o_logsource $logdata + ::shellfilter::log::write $o_logsource $stringdata + return + } + method meta_is_redirection {} { + return 1 + } + } + + #review - we should probably provide a more narrow filter than only strips color - and one that strips most(?) + # - but does it ever really make sense to strip things like "esc(0" and "esc(B" which flip to the G0 G1 characters? (once stripped - things like box-lines become ordinary letters - unlikely to be desired?) + #punk::ansi::ansistrip converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion + #assumes line-buffering. a more advanced filter required if ansicodes can arrive split across separate read or write operations! + oo::class create ansistrip { + variable o_trecord + variable o_enc + variable o_encbuf + variable o_is_junction + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [::tcl::dict::get $tf -encoding] + set o_encbuf "" + if {[::tcl::dict::exists $tf -junction]} { + set o_is_junction [::tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize read write clear flush drain finalize] + } + method finalize {transform_handle} { + my destroy + } + method clear {transform_handle} { + return + } + method watch {transform_handle events} { + } + method drain {transform_handle} { + return "" + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + set outstring [punk::ansi::ansistrip $instring] + return [encoding convertto $o_enc $outstring] + } + method flush {transform_handle} { + return "" + } + #method write {transform_handle bytes} { + # #broken due to occasional unexpected byte sequence + # set instring [encoding convertfrom $o_enc $bytes] + # set outstring [punk::ansi::ansistrip $instring] + # return [encoding convertto $o_enc $outstring] + #} + method write {transform_handle bytes} { + #set instring [tcl::encoding::convertfrom $o_enc $bytes] ;naive approach will break due to unexpected byte sequence - occasionally + #bytes can break at arbitrary points making encoding conversions invalid. + + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [::tcl::string::length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [::tcl::string::range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + + set outstring [punk::ansi::ansistrip $stringdata] + return [tcl::encoding::convertto $o_enc $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + #a test + oo::class create reconvert { + variable o_trecord + variable o_enc + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + } + method initialize {transform_handle mode} { + return [list initialize read write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + } + oo::define reconvert { + method meta_is_redirection {} { + return 0 + } + } + + + #this isn't a particularly nice thing to do to a stream - especially if someone isn't expecting ansi codes sprinkled through it. + #It can be useful for test/debugging + #Due to chunking at random breaks - we have to check if an ansi code in the underlying stream has been split - otherwise our wrapping will break the existing ansi + # + set sixelstart_re {\x1bP([;0-9]*)q} ;#7-bit - todo 8bit + #todo kitty graphics \x1b_G... + #todo iterm graphics + + oo::class create ansiwrap { + variable o_trecord + variable o_enc + variable o_encbuf ;#buffering for partial encoding bytes + variable o_colour + variable o_do_colour + variable o_do_colourlist + variable o_do_normal + variable o_is_junction + variable o_codestack + variable o_gx_state ;#on/off alt graphics + variable o_buffered ;#buffering for partial ansi codes + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set settingsdict [tcl::dict::get $tf -settings] + if {[tcl::dict::exists $settingsdict -colour]} { + set o_colour [tcl::dict::get $settingsdict -colour] + #warning - we can't merge certain extended attributes such as undercurly into single SGR escape sequence + #while some terminals may handle these extended attributes even when merged - we need to cater for those that + #don't. Keeping them as a separate escape allows terminals that don't handle them to ignore just that code without + #affecting the interpretation of the other codes. + set o_do_colour [punk::ansi::a+ {*}$o_colour] + set o_do_colourlist [punk::ansi::ta::get_codes_single $o_do_colour] + set o_do_normal [punk::ansi::a] + } else { + set o_colour {} + set o_do_colour "" + set o_do_colourlist {} + set o_do_normal "" + } + set o_codestack [list] + set o_gx_state [expr {off}] + set o_encbuf "" + set o_buffered "" ;#hold back data that potentially contains partial ansi codes + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + + + #todo - track when in sixel,iterm,kitty graphics data - can be very large + method Trackcodes {chunk} { + #note - caller can use 2 resets in a single unit to temporarily reset to no sgr (override ansiwrap filter) + #e.g [a+ reset reset] (0;0m vs 0;m) + + #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]" + set buf $o_buffered$chunk + set emit "" + if {[string last \x1b $buf] >= 0} { + #detect will detect ansi SGR and gron groff and other codes + #REVIEW - ta::detect won't detect SOS without paired ST for things like PM + # ta::detectcode will - but then split_codes_single will treat unpaired SOS as text? + if {[punk::ansi::ta::detect $buf]} { + #split_codes_single regex faster than split_codes - but more resulting parts + #'single' refers to number of escapes - but can still contain e.g multiple SGR codes (or mode set operations etc) + set parts [punk::ansi::ta::split_codes_single $buf] + #process all pt/code pairs except for trailing pt + foreach {pt code} [lrange $parts 0 end-1] { + #puts "<==[ansistring VIEW -lf 1 $pt]==>" + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$pt + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$pt + } + } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # append emit $o_do_colour$pt$o_do_normal + # #append emit $pt + #} else { + # append emit $pt + #} + + set c1c2 [tcl::string::range $code 0 1] + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + ] $c1c2] 0 3] + switch -- $leadernorm { + 7CSI - 8CSI { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set o_codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set o_codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #todo - make caching is_sgr method + set dup_posns [lsearch -all -exact $o_codestack $code] + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $code + } else { + + } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set o_gx_state on + } + "B" { + set o_gx_state off + } + } + } + default { + #other ansi codes + } + } + append emit $code + } + + + set trailing_pt [lindex $parts end] + if {[string first \x1b $trailing_pt] >= 0} { + #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'" + #may not be plaintext after all + set o_buffered $trailing_pt + #puts stdout "=-=[ansistring VIEWCODES $o_buffered]" + } else { + #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a] + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$trailing_pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$trailing_pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$trailing_pt + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$trailing_pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$trailing_pt + } + } + #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { + # append emit $o_do_colour$trailing_pt$o_do_normal + #} else { + # append emit $trailing_pt + #} + #the previous o_buffered formed the data we emitted - nothing new to buffer because we emitted all parts including the trailing plaintext + set o_buffered "" + } + + + } else { + #REVIEW - this holding a buffer without emitting as we go is ugly. + # - we may do better to detect and retain the opener, then use that opener to avoid false splits within the sequence. + # - we'd then need to detect the appropriate close to restart splitting and codestacking + # - we may still need to retain and append the data to the opener (in some cases?) - which is a slight memory issue - but at least we would emit everything immediately. + + + #puts "-->esc but no detect" + #no complete ansi codes - but at least one esc is present + if {[string index $buf end] eq "\x1b" && [string first \x1b $buf] == [string length $buf]-1} { + #string index in first part of && clause to avoid some unneeded scans of whole string for this test + #we can't use 'string last' - as we need to know only esc is last char in buf + #puts ">>trailing-esc<<" + set o_buffered \x1b + set emit $o_do_colour[string range $buf 0 end-1]$o_do_normal + #set emit [string range $buf 0 end-1] + set buf "" + } else { + set emit_anyway 0 + #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer + if {[punk::ansi::ta::detect_st_open $buf]} { + #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms) + set st_partial_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code + #todo - configurable ST max - use 1k for now + if {$st_partial_len < 1001} { + append o_buffered $chunk + set emit "" + set buf "" + } else { + set emit_anyway 1 + set o_buffered "" + } + } else { + set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code + #most opening sequences are 1,2 or 3 chars - review? + set open_sequence_detected [punk::ansi::ta::detect_open $buf] + if {$possible_code_len > 10 && !$open_sequence_detected} { + set emit_anyway 1 + set o_buffered "" + } else { + #could be composite sequence with params - allow some reasonable max sequence length + #todo - configurable max sequence length + #len 40-50 quite possible for SGR sequence using coloured underlines etc, even without redundancies + # - allow some headroom for redundant codes when the caller didn't merge. + if {$possible_code_len < 101} { + append o_buffered $chunk + set buf "" + set emit "" + } else { + #allow a little more grace if we at least have an opening ansi sequence of any type.. + if {$open_sequence_detected && $possible_code_len < 151} { + append o_buffered $chunk + set buf "" + set emit "" + } else { + set emit_anyway 1 + set o_buffered "" + } + } + } + } + if {$emit_anyway} { + #assert: any time emit_anyway == 1 buf already contains all of previous o_buffered and o_buffered has been cleared. + + #looked ansi-like - but we've given enough length without detecting close.. + #treat as possible plain text with some esc or unrecognised ansi sequence + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # set emit $o_do_colour$buf$o_do_normal + #} else { + # set emit $buf + #} + } + } + } + } else { + #no esc + #puts stdout [a+ yellow]...[a] + #test! + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list {*}$o_do_colourlist {*}$o_codestack]]$buf + } + } + set o_buffered "" + } + return [dict create emit $emit stacksize [llength $o_codestack]] + } + method initialize {transform_handle mode} { + #clear undesirable in terminal output channels (review) + return [list initialize write flush read drain finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method clear {transform_handle} { + #In the context of stderr/stdout - we probably don't want clear to run. + #Terminals might call it in the middle of a split ansi code - resulting in broken output. + #Leave clear of it the init call + puts stdout "" + set emit [tcl::encoding::convertto $o_enc $o_buffered] + set o_buffered "" + return $emit + } + method flush {transform_handle} { + #puts stdout "" + set inputbytes $o_buffered$o_encbuf + set emit [tcl::encoding::convertto $o_enc $inputbytes] + set o_buffered "" + set o_encbuf "" + return $emit + } + method write {transform_handle bytes} { + #set instring [tcl::encoding::convertfrom $o_enc $bytes] ;naive approach will break due to unexpected byte sequence - occasionally + #bytes can break at arbitrary points making encoding conversions invalid. + + set inputbytes $o_encbuf$bytes + set o_encbuf "" + set tail_offset 0 + while {$tail_offset < [string length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [string range $inputbytes 0 end-$tail_offset]} stringdata]} { + incr tail_offset + } + if {$tail_offset > 0} { + if {$tail_offset < [string length $inputbytes]} { + #stringdata from catch statement must be a valid result + set t [expr {$tail_offset - 1}] + set o_encbuf [string range $inputbytes end-$t end] + } else { + set stringdata "" + set o_encbuf $inputbytes + return "" + } + } + set streaminfo [my Trackcodes $stringdata] + set emit [dict get $streaminfo emit] + + #review - wrapping already done in Trackcodes + #if {[dict get $streaminfo stacksize] == 0} { + # #no ansi on the stack - we can wrap + # #review + # set outstring "$o_do_colour$emit$o_do_normal" + #} else { + #} + #if {[llength $o_codestack]} { + # set outstring [punk::ansi::codetype::sgr_merge_singles $o_codestack]$emit + #} else { + # set outstring $emit + #} + #set outstring $emit + + #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<" + #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<" + return [tcl::encoding::convertto $o_enc $emit] + } + method Write_naive {transform_handle bytes} { + set instring [tcl::encoding::convertfrom $o_enc $bytes] + set outstring "$o_do_colour$instring$o_do_normal" + #set outstring ">>>$instring" + return [tcl::encoding::convertto $o_enc $outstring] + } + method drain {transform_handle} { + return "" + } + method read {transform_handle bytes} { + set instring [tcl::encoding::convertfrom $o_enc $bytes] + set outstring "$o_do_colour$instring$o_do_normal" + return [tcl::encoding::convertto $o_enc $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + #todo - something + oo::class create rebuffer { + variable o_trecord + variable o_enc + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + } + method initialize {transform_handle mode} { + return [list initialize read write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + #set outstring [string map [list \n ] $instring] + set outstring $instring + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define rebuffer { + method meta_is_redirection {} { + return 0 + } + } + + #has slight buffering/withholding of lone training cr - we can't be sure that a cr at end of chunk is part of \r\n sequence + oo::class create tounix { + variable o_trecord + variable o_enc + variable o_last_char_was_cr + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + set o_last_char_was_cr 0 + } + method initialize {transform_handle mode} { + return [list initialize write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #don't use read + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + #set outstring [string map [list \n ] $instring] + + if {$o_last_char_was_cr} { + set instring "\r$instring" + } + + set outstring [string map {\r\n \n} $instring] + set lastchar [string range $outstring end end] + if {$lastchar eq "\r"} { + set o_last_char_was_cr 1 + set outstring [string range $outstring 0 end-1] + } else { + set o_last_char_was_cr 0 + } + #review! can we detect eof here on the transform_handle? + #if eof, we don't want to strip a trailing \r + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define tounix { + method meta_is_redirection {} { + return $o_is_junction + } + } + #write to handle case where line-endings already \r\n too + oo::class create towindows { + variable o_trecord + variable o_enc + variable o_last_char_was_cr + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + set o_last_char_was_cr 0 + } + method initialize {transform_handle mode} { + return [list initialize write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #don't use read + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + #set outstring [string map [list \n ] $instring] + + if {$o_last_char_was_cr} { + set instring "\r$instring" + } + + set outstring [string map {\r\n \uFFFF} $instring] + set outstring [string map {\n \r\n} $outstring] + set outstring [string map {\uFFFF \r\n} $outstring] + + set lastchar [string range $outstring end end] + if {$lastchar eq "\r"} { + set o_last_char_was_cr 1 + set outstring [string range $outstring 0 end-1] + } else { + set o_last_char_was_cr 0 + } + #review! can we detect eof here on the transform_handle? + #if eof, we don't want to strip a trailing \r + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define towindows { + method meta_is_redirection {} { + return $o_is_junction + } + } + + } +} + +# ---------------------------------------------------------------------------- +#review float/sink metaphor. +#perhaps something with the concept of upstream and downstream? +#need concepts for push towards data, sit in middle where placed, and lag at tail of data stream. +## upstream for stdin is at the bottom of the stack and for stdout is the top of the stack. +#upstream,neutral-upstream,downstream,downstream-aside,downstream-replace (default neutral-upstream - require action 'stack' to use standard channel stacking concept and ignore other actions) +#This is is a bit different from the float/sink metaphor which refers to the channel stacking order as opposed to the data-flow direction. +#The idea would be that whether input or output +# upstream additions go to the side closest to the datasource +# downstream additions go furthest from the datasource +# - all new additions go ahead of any diversions as the most upstream diversion is the current end of the stream in a way. +# - this needs review regarding subsequent removal of the diversion and whether filters re-order in response.. +# or if downstream & neutral additions are reclassified upon insertion if they land among existing upstreams(?) +# neutral-upstream goes to the datasource side of the neutral-upstream list. +# No 'neutral' option provided so that we avoid the need to think forwards or backwards when adding stdin vs stdout shellfilter does the necessary pop/push reordering. +# No 'neutral-downstream' to reduce complexity. +# downstream-replace & downstream-aside head downstream to the first diversion they encounter. ie these actions are no longer referring to the stack direction but only the dataflow direction. +# +# ---------------------------------------------------------------------------- +# +# 'filters' are transforms that don't redirect +# - limited range of actions to reduce complexity. +# - any requirement not fulfilled by float,sink,sink-replace,sink-sideline should be done by multiple pops and pushes +# +#actions can float to top of filters or sink to bottom of filters +#when action is of type sink, it can optionally replace or sideline the first non-filter it encounters (highest redirection on the stack.. any lower are starved of the stream anyway) +# - sideline means to temporarily replace the item and keep a record, restoring if/when we are removed from the transform stack +# +##when action is of type float it can't replace or sideline anything. A float is added above any existing floats and they stay in the same order relative to each other, +#but non-floats added later will sit below all floats. +#(review - float/sink initially designed around output channels. For stdin the dataflow is reversed. implement float-aside etc?) +# +# +#action: float sink sink-replace,sink-sideline +# +# +## note - whether stack is for input or output we maintain it in the same direction - which is in sync with the tcl chan pop chan push concept. +## +namespace eval shellfilter::stack { + namespace export {[a-z]*} + namespace ensemble create + #todo - implement as oo ? + variable pipelines [list] + + proc items {} { + #review - stdin,stdout,stderr act as pre-existing pipelines, and we can't create a new one with these names - so they should probably be autoconfigured and listed.. + # - but in what contexts? only when we find them in [chan names]? + variable pipelines + return [dict keys $pipelines] + } + proc item {pipename} { + variable pipelines + return [dict get $pipelines $pipename] + } + proc item_tophandle {pipename} { + variable pipelines + set handle "" + if {[dict exists $pipelines $pipename stack]} { + set stack [dict get $pipelines $pipename stack] + set topstack [lindex $stack end] ;#last item in stack is top (for output channels anyway) review comment. input chans? + if {$topstack ne ""} { + if {[dict exists $topstack -handle]} { + set handle [dict get $topstack -handle] + } + } + } + return $handle + } + proc status {{pipename *} args} { + variable pipelines + set pipecount [dict size $pipelines] + set tabletitle "$pipecount pipelines active" + set t [textblock::class::table new $tabletitle] + $t add_column -headers [list channel-ident] + $t add_column -headers [list device-info localchan] + $t configure_column 1 -header_colspans {3} + $t add_column -headers [list "" remotechan] + $t add_column -headers [list "" tid] + $t add_column -headers [list stack-info] + foreach k [dict keys $pipelines $pipename] { + set lc [dict get $pipelines $k device localchan] + set rc [dict get $pipelines $k device remotechan] + if {[dict exists $k device workertid]} { + set tid [dict get $pipelines $k device workertid] + } else { + set tid "-" + } + set stack [dict get $pipelines $k stack] + if {![llength $stack]} { + set stackinfo "" + } else { + set tbl_inner [textblock::class::table new] + $tbl_inner configure -show_edge 0 + foreach rec $stack { + set handle [punk::lib::dict_getdef $rec -handle ""] + set id [punk::lib::dict_getdef $rec -id ""] + set transform [namespace tail [punk::lib::dict_getdef $rec -transform ""]] + set settings [punk::lib::dict_getdef $rec -settings ""] + $tbl_inner add_row [list $id $transform $handle $settings] + } + set stackinfo [$tbl_inner print] + $tbl_inner destroy + } + $t add_row [list $k $lc $rc $tid $stackinfo] + } + set result [$t print] + $t destroy + return $result + } + proc status1 {{pipename *} args} { + variable pipelines + + set pipecount [dict size $pipelines] + set tableprefix "$pipecount pipelines active\n" + foreach p [dict keys $pipelines] { + append tableprefix " " $p \n + } + package require overtype + #todo -verbose + set table "" + set ac1 [string repeat " " 15] + set ac2 [string repeat " " 42] + set ac3 [string repeat " " 70] + append table "[overtype::left $ac1 channel-ident] " + append table "[overtype::left $ac2 device-info] " + append table "[overtype::left $ac3 stack-info]" + append table \n + + + set bc1 [string repeat " " 5] ;#stack id + set bc2 [string repeat " " 25] ;#transform + set bc3 [string repeat " " 50] ;#settings + + foreach k [dict keys $pipelines $pipename] { + set lc [dict get $pipelines $k device localchan] + if {[dict exists $k device workertid]} { + set tid [dict get $pipelines $k device workertid] + } else { + set tid "" + } + + + set col1 [overtype::left $ac1 $k] + set col2 [overtype::left $ac2 "localchan: $lc tid:$tid"] + + set stack [dict get $pipelines $k stack] + if {![llength $stack]} { + set col3 $ac3 + } else { + set rec [lindex $stack 0] + set bcol1 [overtype::left $bc1 [dict get $rec -id]] + set bcol2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] + set bcol3 [overtype::left $bc3 [dict get $rec -settings]] + set stackrow "$bcol1 $bcol2 $bcol3" + set col3 [overtype::left $ac3 $stackrow] + } + + append table "$col1 $col2 $col3\n" + + + foreach rec [lrange $stack 1 end] { + set col1 $ac1 + set col2 $ac2 + if {[llength $rec]} { + set bc1 [overtype::left $bc1 [dict get $rec -id]] + set bc2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] + set bc3 [overtype::left $bc3 [dict get $rec -settings]] + set stackrow "$bc1 $bc2 $bc3" + set col3 [overtype::left $ac3 $stackrow] + } else { + set col3 $ac3 + } + append table "$col1 $col2 $col3\n" + } + + } + return $tableprefix$table + } + #used for output channels - we usually want to sink redirections below the floaters and down to topmost existing redir + proc _get_stack_floaters {stack} { + set floaters [list] + foreach t [lreverse $stack] { + switch -- [dict get $t -action] { + float { + lappend floaters $t + } + default { + break + } + } + } + return [lreverse $floaters] + } + + + + #for output-channel sinking + proc _get_stack_top_redirection {stack} { + set r 0 ;#reverse index + foreach t [lreverse $stack] { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index + return [list index $idx record $t] + } + incr r + } + #not found + return [list index -1 record {}] + } + #exclude float-locked, locked, sink-locked + proc _get_stack_top_redirection_replaceable {stack} { + set r 0 ;#reverse index + foreach t [lreverse $stack] { + set action [dict get $t -action] + if {![string match "*locked*" $action]} { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index + return [list index $idx record $t] + } + } + incr r + } + #not found + return [list index -1 record {}] + } + + + #for input-channels ? + proc _get_stack_bottom_redirection {stack} { + set i 0 + foreach t $stack { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + return [linst index $i record $t] + } + incr i + } + #not found + return [list index -1 record {}] + } + + + proc get_next_counter {pipename} { + variable pipelines + #use dictn incr ? + set counter [dict get $pipelines $pipename counter] + incr counter + dict set pipelines $pipename counter $counter + return $counter + } + + proc unwind {pipename} { + variable pipelines + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $pipelines $pipename device localchan] + foreach tf [lreverse $stack] { + chan pop $localchan + } + dict set pipelines $pipename [list] + } + #todo + proc delete {pipename {wait 0}} { + variable pipelines + set pipeinfo [dict get $pipelines $pipename] + set deviceinfo [dict get $pipeinfo device] + set localchan [dict get $deviceinfo localchan] + unwind $pipename + + #release associated thread + set tid [dict get $deviceinfo workertid] + if {$wait} { + thread::release -wait $tid + } else { + thread::release $tid + } + + #Memchan closes without error - tcl::chan::fifo2 raises something like 'can not find channel named "rc977"' - REVIEW. why? + catch {chan close $localchan} + } + #review - proc name clarity is questionable. remove_stackitem? + proc remove {pipename remove_id} { + variable pipelines + if {![dict exists $pipelines $pipename]} { + puts stderr "WARNING: shellfilter::stack::remove pipename '$pipename' not found in pipelines dict: '$pipelines' [info level -1]" + return + } + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $pipelines $pipename device localchan] + set posn 0 + set idposn -1 + set asideposn -1 + foreach t $stack { + set id [dict get $t -id] + if {$id eq $remove_id} { + set idposn $posn + break + } + #look into asides (only can be one for now) + if {[llength [dict get $t -aside]]} { + set a [dict get $t -aside] + if {[dict get $a -id] eq $remove_id} { + set asideposn $posn + break + } + } + incr posn + } + + if {$asideposn > 0} { + #id wasn't found directly in stack, but in an -aside. we don't need to pop anything - just clear this aside record + set container [lindex $stack $asideposn] + dict set container -aside {} + lset stack $asideposn $container + dict set pipelines $pipename stack $stack + } else { + if {$idposn < 0} { + ::shellfilter::log::write shellfilter "ERROR shellfilter::stack::remove $pipename id '$remove_id' not found" + puts stderr "|WARNING>shellfilter::stack::remove $pipename id '$remove_id' not found" + return 0 + } + set removed_item [lindex $stack $idposn] + + #include idposn in poplist + set poplist [lrange $stack $idposn end] + set stack [lreplace $stack $idposn end] + #pop all chans before adding anything back in! + foreach p $poplist { + chan pop $localchan + } + + if {[llength [dict get $removed_item -aside]]} { + set restore [dict get $removed_item -aside] + set t [dict get $restore -transform] + set tsettings [dict get $restore -settings] + set obj [$t new $restore] + set h [chan push $localchan $obj] + dict set restore -handle $h + dict set restore -obj $obj + lappend stack $restore + } + + #put popped back except for the first one, which we want to remove + foreach p [lrange $poplist 1 end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + dict set p -handle $h + dict set p -obj $obj + lappend stack $p + } + dict set pipelines $pipename stack $stack + } + #JMNJMN 2025 review! + #show_pipeline $pipename -note "after_remove $remove_id" + return 1 + } + + #pop a number of items of the top of the stack, add our transform record, and add back all (or the tail of poplist if pushstartindex > 0) + proc insert_transform {pipename stack transformrecord poplist {pushstartindex 0}} { + variable pipelines + set bottom_pop_posn [expr {[llength $stack] - [llength $poplist]}] + set poplist [lrange $stack $bottom_pop_posn end] + set stack [lreplace $stack $bottom_pop_posn end] + + set localchan [dict get $pipelines $pipename device localchan] + foreach p [lreverse $poplist] { + chan pop $localchan + } + set transformname [dict get $transformrecord -transform] + set transformsettings [dict get $transformrecord -settings] + set obj [$transformname new $transformrecord] + set h [chan push $localchan $obj] + dict set transformrecord -handle $h + dict set transformrecord -obj $obj + dict set transformrecord -note "insert_transform" + lappend stack $transformrecord + foreach p [lrange $poplist $pushstartindex end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + #retain previous -id - code that added it may have kept reference and not expecting it to change + dict set p -handle $h + dict set p -obj $obj + dict set p -note "re-added" + + lappend stack $p + } + return $stack + } + + #fifo2 + proc new {pipename args} { + variable pipelines + if {($pipename in [dict keys $pipelines]) || ($pipename in [chan names])} { + error "shellfilter::stack::new error: pipename '$pipename' already exists" + } + + set opts [dict merge {-settings {}} $args] + set defaultsettings [dict create -raw 1 -buffering line -direction out] + set targetsettings [dict merge $defaultsettings [dict get $opts -settings]] + + set direction [dict get $targetsettings -direction] + + #pipename is the source/facility-name ? + if {$direction eq "out"} { + set pipeinfo [shellfilter::pipe::open_out $pipename $targetsettings] + } else { + puts stderr "|jn> pipe::open_in $pipename $targetsettings" + set pipeinfo [shellfilter::pipe::open_in $pipename $targetsettings] + } + #open_out/open_in will configure buffering based on targetsettings + + set program_chan [dict get $pipeinfo localchan] + set worker_chan [dict get $pipeinfo remotechan] + set workertid [dict get $pipeinfo workertid] + + + set deviceinfo [dict create pipename $pipename localchan $program_chan remotechan $worker_chan workertid $workertid direction $direction] + dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] + + return $deviceinfo + } + #we 'add' rather than 'push' because transforms can float,sink and replace/sideline so they don't necessarily go to the top of the transform stack + proc add {pipename transformname args} { + variable pipelines + #chan names doesn't reflect available channels when transforms are in place + #e.g stdout may exist but show as something like file191f5b0dd80 + if {($pipename ni [dict keys $pipelines])} { + if {[catch {eof $pipename} is_eof]} { + error "shellfilter::stack::add no existing chan or pipename matching '$pipename' in channels:[chan names] or pipelines:$pipelines use stdin/stderr/stdout or shellfilter::stack::new " + } + } + set args [dict merge {-action "" -settings {}} $args] + set action [dict get $args -action] + set transformsettings [dict get $args -settings] + if {[string first "::" $transformname] < 0} { + set transformname ::shellfilter::chan::$transformname + } + if {![llength [info commands $transformname]]} { + error "shellfilter::stack::push unknown transform '$transformname'" + } + + + if {![dict exists $pipelines $pipename]} { + #pipename must be in chan names - existing device/chan + #record a -read and -write end even if the device is only being used as one or the other + set deviceinfo [dict create pipename $pipename localchan $pipename remotechan {}] + dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] + } else { + set deviceinfo [dict get $pipelines $pipename device] + } + + set id [get_next_counter $pipename] + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $deviceinfo localchan] + + #we redundantly store chan in each transform - makes debugging clearer + # -encoding similarly could be stored only at the pipeline level (or even queried directly each filter-read/write), + # but here it may help detect unexpected changes during lifetime of the stack and avoids the chance of callers incorrectly using the transform handle?) + # jn + set transform_record [list -id $id -chan $pipename -encoding [chan configure $localchan -encoding] -transform $transformname -aside {} {*}$args] + switch -glob -- $action { + float - float-locked { + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + lappend stack $transform_record + } + "" - locked { + set floaters [_get_stack_floaters $stack] + if {![llength $floaters]} { + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + lappend stack $transform_record + } else { + set poplist $floaters + set stack [insert_transform $pipename $stack $transform_record $poplist] + } + } + "sink*" { + set redirinfo [_get_stack_top_redirection $stack] + set idx_existing_redir [dict get $redirinfo index] + if {$idx_existing_redir == -1} { + #no existing redirection transform on the stack + #pop everything.. add this record as the first redirection on the stack + set poplist $stack + set stack [insert_transform $pipename $stack $transform_record $poplist] + } else { + switch -glob -- $action { + "sink-replace" { + #include that index in the poplist + set poplist [lrange $stack $idx_existing_redir end] + #pop all from idx_existing_redir to end, but put back 'lrange $poplist 1 end' + set stack [insert_transform $pipename $stack $transform_record $poplist 1] + } + "sink-aside*" { + set existing_redir_record [lindex $stack $idx_existing_redir] + if {[string match "*locked*" [dict get $existing_redir_record -action]]} { + set put_aside 0 + #we can't aside this one - sit above it instead. + set poplist [lrange $stack $idx_existing_redir+1 end] + set stack [lrange $stack 0 $idx_existing_redir] + } else { + set put_aside 1 + dict set transform_record -aside [lindex $stack $idx_existing_redir] + set poplist [lrange $stack $idx_existing_redir end] + set stack [lrange $stack 0 $idx_existing_redir-1] + } + foreach p $poplist { + chan pop $localchan + } + set transformname [dict get $transform_record -transform] + set transform_settings [dict get $transform_record -settings] + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + dict set transform_record -note "insert_transform-with-aside" + lappend stack $transform_record + #add back poplist *except* the one we transferred into -aside (if we were able) + foreach p [lrange $poplist $put_aside end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + #retain previous -id - code that added it may have kept reference and not expecting it to change + dict set p -handle $h + dict set p -obj $obj + dict set p -note "re-added-after-sink-aside" + lappend stack $p + } + } + default { + #plain "sink" + #we only sink to the topmost redirecting filter - which makes sense for an output channel + #For stdin.. this is more problematic as we're more likely to want to intercept the bottom most redirection. + #todo - review. Consider making default insert position for input channels to be at the source... and float/sink from there. + # - we don't currently know from the stack api if adding input vs output channel - so this needs work to make intuitive. + # consider splitting stack::add to stack::addinput stack::addoutput to split the different behaviour + set poplist [lrange $stack $idx_existing_redir+1 end] + set stack [insert_transform $pipename $stack $transform_record $poplist] + } + } + } + } + default { + error "shellfilter::stack::add unimplemented action '$action'" + } + } + + dict set pipelines $pipename stack $stack + #puts stdout "==" + #puts stdout "==>stack: $stack" + #puts stdout "==" + + #JMNJMN + #show_pipeline $pipename -note "after_add $transformname $args" + return $id + } + proc show_pipeline {pipename args} { + variable pipelines + set stack [dict get $pipelines $pipename stack] + set tag "SHELLFILTER::STACK" + #JMN - load from config + #::shellfilter::log::open $tag {-syslog 127.0.0.1:514} + if {[catch { + ::shellfilter::log::open $tag {-syslog ""} + } err]} { + #e.g safebase interp can't load required modules such as shellthread (or Thread) + puts stderr "shellfilter::show_pipeline cannot open log" + return + } + ::shellfilter::log::write $tag "transform stack for $pipename $args" + foreach tf $stack { + ::shellfilter::log::write $tag " $tf" + } + + } +} + + +namespace eval shellfilter { + variable sources [list] + variable stacks [dict create] + + proc ::shellfilter::redir_channel_to_log {chan args} { + variable sources + set default_logsettings [dict create \ + -tag redirected_$chan -syslog "" -file ""\ + ] + if {[dict exists $args -action]} { + set action [dict get $args -action] + } else { + # action "sink" is a somewhat reasonable default for an output redirection transform + # but it can make it harder to configure a plain ordered stack if the user is not expecting it, so we'll default to stack + # also.. for stdin transform sink makes less sense.. + #todo - default "stack" instead of empty string + set action "" + } + if {[dict exists $args -settings]} { + set logsettings [dict get $args -settings] + } else { + set logsettings {} + } + + set logsettings [dict merge $default_logsettings $logsettings] + set tag [dict get $logsettings -tag] + if {$tag ni $sources} { + lappend sources $tag + } + + set id [shellfilter::stack::add $chan logonly -action $action -settings $logsettings] + return $id + } + + proc ::shellfilter::redir_output_to_log {tagprefix args} { + variable sources + + set default_settings [list -tag ${tagprefix} -syslog "" -file ""] + + set opts [dict create -action "" -settings {}] + set opts [dict merge $opts $args] + set optsettings [dict get $opts -settings] + set settings [dict merge $default_settings $optsettings] + + set tag [dict get $settings -tag] + if {$tag ne $tagprefix} { + error "shellfilter::redir_output_to_log -tag value must match supplied tagprefix:'$tagprefix'. Omit -tag, or make it the same. It will automatically be suffixed with stderr and stdout. Use redir_channel_to_log if you want to separately configure each channel" + } + lappend sources ${tagprefix}stdout ${tagprefix}stderr + + set stdoutsettings $settings + dict set stdoutsettings -tag ${tagprefix}stdout + set stderrsettings $settings + dict set stderrsettings -tag ${tagprefix}stderr + + set idout [redir_channel_to_log stdout -action [dict get $opts -action] -settings $stdoutsettings] + set iderr [redir_channel_to_log stderr -action [dict get $opts -action] -settings $stderrsettings] + + return [list $idout $iderr] + } + + #eg try: set v [list #a b c] + #vs set v {#a b c} + proc list_is_canonical l { + #courtesy DKF via wiki https://wiki.tcl-lang.org/page/BNF+for+Tcl + if {[catch {llength $l}]} {return 0} + string equal $l [list {*}$l] + } + + #return a dict keyed on numerical list index showing info about each element + # - particularly + # 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list + # 'head_tail_chars' to show current first and last character (in case it's wrapped e.g in double or single quotes or an existing set of braces) + proc list_element_info {inputlist} { + set i 0 + set info [dict create] + set testlist [list] + foreach original_item $inputlist { + #--- + # avoid sharing internal rep with original items in the list (avoids shimmering of rep in original list for certain items such as paths) + unset -nocomplain item + append item $original_item {} + #--- + + set iteminfo [dict create] + set itemlen [string length $item] + lappend testlist $item + set tcl_len [string length $testlist] + set diff [expr {$tcl_len - $itemlen}] + if {$diff == 0} { + dict set iteminfo wouldbrace 0 + dict set iteminfo wouldescape 0 + } else { + #test for escaping vs bracing! + set testlistchars [split $testlist ""] + if {([lindex $testlistchars 0] eq "\{") && ([lindex $testlistchars end] eq "\}")} { + dict set iteminfo wouldbrace 1 + dict set iteminfo wouldescape 0 + } else { + dict set iteminfo wouldbrace 0 + dict set iteminfo wouldescape 1 + } + } + set testlist [list] + set charlist [split $item ""] + set char_a [lindex $charlist 0] + set char_b [lindex $charlist 1] + set char_ab ${char_a}${char_b} + set char_y [lindex $charlist end-1] + set char_z [lindex $charlist end] + set char_yz ${char_y}${char_z} + + if { ("{" in $charlist) || ("}" in $charlist) } { + dict set iteminfo has_braces 1 + set innerchars [lrange $charlist 1 end-1] + if {("{" in $innerchars) || ("}" in $innerchars)} { + dict set iteminfo has_inner_braces 1 + } else { + dict set iteminfo has_inner_braces 0 + } + } else { + dict set iteminfo has_braces 0 + dict set iteminfo has_inner_braces 0 + } + + #todo - brace/char counting to determine if actually 'wrapped' + #e.g we could have list element {((abc)} - which appears wrapped if only looking at first and last chars. + #also {(x) (y)} as a list member.. how to treat? + if {$itemlen <= 1} { + dict set iteminfo apparentwrap "not" + } else { + #todo - switch on $char_a$char_z + if {($char_a eq {"}) && ($char_z eq {"})} { + dict set iteminfo apparentwrap "doublequotes" + } elseif {($char_a eq "'") && ($char_z eq "'")} { + dict set iteminfo apparentwrap "singlequotes" + } elseif {($char_a eq "(") && ($char_z eq ")")} { + dict set iteminfo apparentwrap "brackets" + } elseif {($char_a eq "\{") && ($char_z eq "\}")} { + dict set iteminfo apparentwrap "braces" + } elseif {($char_a eq "^") && ($char_z eq "^")} { + dict set iteminfo apparentwrap "carets" + } elseif {($char_a eq "\[") && ($char_z eq "\]")} { + dict set iteminfo apparentwrap "squarebrackets" + } elseif {($char_a eq "`") && ($char_z eq "`")} { + dict set iteminfo apparentwrap "backquotes" + } elseif {($char_a eq "\n") && ($char_z eq "\n")} { + dict set iteminfo apparentwrap "lf-newline" + } elseif {($char_ab eq "\r\n") && ($char_yz eq "\r\n")} { + dict set iteminfo apparentwrap "crlf-newline" + } else { + dict set iteminfo apparentwrap "not-determined" + } + + } + dict set iteminfo wrapbalance "unknown" ;#a hint to caller that apparentwrap is only a guide. todo - possibly make wrapbalance indicate 0 for unbalanced.. and positive numbers for outer-count of wrappings. + #e.g {((x)} == 0 {((x))} == 1 {(x) (y (z))} == 2 + dict set iteminfo head_tail_chars [list $char_a $char_z] + set namemap [list \ + \r cr\ + \n lf\ + {"} doublequote\ + {'} singlequote\ + "`" backquote\ + "^" caret\ + \t tab\ + " " sp\ + "\[" lsquare\ + "\]" rsquare\ + "(" lbracket\ + ")" rbracket\ + "\{" lbrace\ + "\}" rbrace\ + \\ backslash\ + / forwardslash\ + ] + if {[string length $char_a]} { + set char_a_name [string map $namemap $char_a] + } else { + set char_a_name "emptystring" + } + if {[string length $char_z]} { + set char_z_name [string map $namemap $char_z] + } else { + set char_z_name "emptystring" + } + + dict set iteminfo head_tail_names [list $char_a_name $char_z_name] + dict set iteminfo len $itemlen + dict set iteminfo difflen $diff ;#2 for braces, 1 for quoting?, or 0. + dict set info $i $iteminfo + incr i + } + return $info + } + + + #parse bracketed expression (e.g produced by vim "shellxquote=(" ) into a tcl (nested) list + #e.g {(^c:/my spacey/path^ >^somewhere^)} + #e.g {(blah (etc))}" + #Result is always a list - even if only one toplevel set of brackets - so it may need [lindex $result 0] if input is the usual case of {( ...)} + # - because it also supports the perhaps less likely case of: {( ...) unbraced (...)} etc + # Note that + #maintenance warning - duplication in branches for bracketed vs unbracketed! + proc parse_cmd_brackets {str} { + #wordwrappers currently best suited to non-bracket entities - no bracket matching within - anything goes until end-token reached. + # - but.. they only take effect where a word can begin. so a[x y] may be split at the space unless it's within some other wraper e.g " a[x y]" will not break at the space + # todo - consider extending the in-word handling of word_bdepth which is currently only applied to () i.e aaa(x y) is supported but aaa[x y] is not as the space breaks the word up. + set wordwrappers [list \ + "\"" [list "\"" "\"" "\""]\ + {^} [list "\"" "\"" "^"]\ + "'" [list "'" "'" "'"]\ + "\{" [list "\{" "\}" "\}"]\ + {[} [list {[} {]} {]}]\ + ] ;#dict mapping start_character to {replacehead replacetail expectedtail} + set shell_specials [list "|" "|&" "<" "<@" "<<" ">" "2>" ">&" ">>" "2>>" ">>&" ">@" "2>@" "2>@1" ">&@" "&" "&&" ] ;#words/chars that may precede an opening bracket but don't merge with the bracket to form a word. + #puts "pb:$str" + set in_bracket 0 + set in_word 0 + set word "" + set result {} + set word_bdepth 0 + set word_bstack [list] + set wordwrap "" ;#only one active at a time + set bracketed_elements [dict create] + foreach char [split $str ""] { + #puts "c:$char bracketed:$bracketed_elements" + if {$in_bracket > 0} { + if {$in_word} { + if {[string length $wordwrap]} { + #anything goes until end-char + #todo - lookahead and only treat as closing if before a space or ")" ? + lassign [dict get $wordwrappers $wordwrap] _open closing endmark + if {$char eq $endmark} { + set wordwrap "" + append word $closing + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } else { + append word $char + } + } else { + if {$word_bdepth == 0} { + #can potentially close off a word - or start a new one if word-so-far is a shell-special + if {$word in $shell_specials} { + if {$char eq ")"} { + dict lappend bracketed_elements $in_bracket $word + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + set word "" + set in_word 0 + } elseif {[regexp {[\s]} $char]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + incr in_bracket + } else { + #at end of shell-specials is another point to look for word started by a wordwrapper char + #- expect common case of things like >^/my/path^ + if {$char in [dict keys $wordwrappers]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 1 ;#just for explicitness.. we're straight into the next word. + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + #something unusual.. keep going with word! + append word $char + } + } + } else { + + if {$char eq ")"} { + dict lappend bracketed_elements $in_bracket $word + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + set word "" + set in_word 0 + } elseif {[regexp {[\s]} $char]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + #ordinary word up-against and opening bracket - brackets are part of word. + incr word_bdepth + append word "(" + } else { + append word $char + } + } + } else { + #currently only () are used for word_bdepth - todo add all or some wordwrappers chars so that the word_bstack can have multiple active. + switch -- $char { + "(" { + incr word_bdepth + lappend word_bstack $char + append word $char + } + ")" { + incr word_bdepth -1 + set word_bstack [lrange $word_bstack 0 end-1] + append word $char + } + default { + #spaces and chars added to word as it's still in a bracketed section + append word $char + } + } + } + } + } else { + + if {$char eq "("} { + incr in_bracket + + } elseif {$char eq ")"} { + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + } elseif {[regexp {[\s]} $char]} { + # + } else { + #first char of word - look for word-wrappers + if {$char in [dict keys $wordwrappers]} { + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + set word $char + } + set in_word 1 + } + } + } else { + if {$in_word} { + if {[string length $wordwrap]} { + lassign [dict get $wordwrappers $wordwrap] _open closing endmark + if {$char eq $endmark} { + set wordwrap "" + append word $closing + lappend result $word + set word "" + set in_word 0 + } else { + append word $char + } + } else { + + if {$word_bdepth == 0} { + if {$word in $shell_specials} { + if {[regexp {[\s]} $char]} { + lappend result $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + lappend result $word + set word "" + set in_word 0 + incr in_bracket + } else { + #at end of shell-specials is another point to look for word started by a wordwrapper char + #- expect common case of things like >^/my/path^ + if {$char in [dict keys $wordwrappers]} { + lappend result $word + set word "" + set in_word 1 ;#just for explicitness.. we're straight into the next word. + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + #something unusual.. keep going with word! + append word $char + } + } + + } else { + if {[regexp {[\s)]} $char]} { + lappend result $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + incr word_bdepth + append word $char + } else { + append word $char + } + } + } else { + switch -- $char { + "(" { + incr word_bdepth + append word $char + } + ")" { + incr word_bdepth -1 + append word $char + } + default { + append word $char + } + } + } + } + } else { + if {[regexp {[\s]} $char]} { + #insig whitespace(?) + } elseif {$char eq "("} { + incr in_bracket + dict set bracketed_elements $in_bracket [list] + } elseif {$char eq ")"} { + error "unbalanced bracket - unable to proceed result so far: $result bracketed_elements:$bracketed_elements" + } else { + #first char of word - look for word-wrappers + if {$char in [dict keys $wordwrappers]} { + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + set word $char + } + set in_word 1 + } + } + } + #puts "----$bracketed_elements" + } + if {$in_bracket > 0} { + error "shellfilter::parse_cmd_brackets missing close bracket. input was '$str'" + } + if {[dict exists $bracketed_elements 0]} { + #lappend result [lindex [dict get $bracketed_elements 0] 0] + lappend result [dict get $bracketed_elements 0] + } + if {$in_word} { + lappend result $word + } + return $result + } + + #only double quote if argument not quoted with single or double quotes + proc dquote_if_not_quoted {a} { + set wrapchars [string cat [string range $a 0 0] [string range $a end end]] + switch -- $wrapchars { + {""} - {''} { + return $a + } + default { + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + } + } + + #proc dquote_if_not_bracketed/braced? + + #wrap in double quotes if not double-quoted + proc dquote_if_not_dquoted {a} { + set wrapchars [string cat [string range $a 0 0] [string range $a end end]] + switch -- $wrapchars { + {""} { + return $a + } + default { + #escape any inner quotes.. + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + } + } + proc dquote {a} { + #escape any inner quotes.. + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + proc get_scriptrun_from_cmdlist_dquote_if_not {cmdlist {shellcmdflag ""}} { + set scr [auto_execok "script"] + if {[string length $scr]} { + #set scriptrun "( $c1 [lrange $cmdlist 1 end] )" + set arg1 [lindex $cmdlist 0] + if {[string first " " $arg1]>0} { + set c1 [dquote_if_not_quoted $arg1] + #set c1 "\"$arg1\"" + } else { + set c1 $arg1 + } + + if {[string length $shellcmdflag]} { + set scriptrun "$shellcmdflag \$($c1 " + } else { + set scriptrun "\$($c1 " + } + #set scriptrun "$c1 " + foreach a [lrange $cmdlist 1 end] { + #set a [string map [list "/" "//"] $a] + #set a [string map [list "\"" "\\\""] $a] + if {[string first " " $a] > 0} { + append scriptrun [dquote_if_not_quoted $a] + } else { + append scriptrun $a + } + append scriptrun " " + } + set scriptrun [string trim $scriptrun] + append scriptrun ")" + #return [list $scr -q -e -c $scriptrun /dev/null] + return [list $scr -e -c $scriptrun /dev/null] + } else { + return $cmdlist + } + } + + proc ::shellfilter::trun {commandlist args} { + #jmn + } + + + # run a command (or tcl script) with tees applied to stdout/stderr/stdin (or whatever channels are being used) + # By the point run is called - any transforms should already be in place on the channels if they're needed. + # The tees will be inline with none,some or all of those transforms depending on how the stack was configured + # (upstream,downstream configured via -float,-sink etc) + proc ::shellfilter::run {commandlist args} { + #must be a list. If it was a shell commandline string. convert it elsewhere first. + + variable sources + set runtag "shellfilter-run" + #set tid [::shellfilter::log::open $runtag [list -syslog 127.0.0.1:514]] + set tid [::shellfilter::log::open $runtag [list -syslog ""]] + if {[catch {llength $commandlist} listlen]} { + set listlen "" + } + ::shellfilter::log::write $runtag " commandlist:'$commandlist' listlen:$listlen strlen:[string length $commandlist]" + + #flush stdout + #flush stderr + + #adding filters with sink-aside will temporarily disable the existing redirection + #All stderr/stdout from the shellcommand will now tee to the underlying stderr/stdout as well as the configured syslog + + set defaults [dict create \ + -teehandle command \ + -outchan stdout \ + -errchan stderr \ + -inchan stdin \ + -tclscript 0 \ + ] + set opts [dict merge $defaults $args] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set outchan [dict get $opts -outchan] + set errchan [dict get $opts -errchan] + set inchan [dict get $opts -inchan] + set teehandle [dict get $opts -teehandle] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set is_script [dict get $opts -tclscript] + dict unset opts -tclscript ;#don't pass it any further + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set teehandle_out ${teehandle}out ;#default commandout + set teehandle_err ${teehandle}err + set teehandle_in ${teehandle}in + + + #puts stdout "shellfilter initialising tee_to_pipe transforms for in/out/err" + + # sources should be added when stack::new called instead(?) + foreach source [list $teehandle_out $teehandle_err] { + if {$source ni $sources} { + lappend sources $source + } + } + set outdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_out device] + set outpipechan [dict get $outdeviceinfo localchan] + set errdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_err device] + set errpipechan [dict get $errdeviceinfo localchan] + + #set indeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_in device] + #set inpipechan [dict get $indeviceinfo localchan] + + #NOTE:These transforms are not necessarily at the top of each stack! + #The float/sink mechanism, along with whether existing transforms are diversionary decides where they sit. + set id_out [shellfilter::stack::add $outchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_out -pipechan $outpipechan]] + set id_err [shellfilter::stack::add $errchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_err -pipechan $errpipechan]] + + # need to use os level channel handle for stdin - try named pipes (or even sockets) instead of fifo2 for this + # If non os-level channel - the command can't be run with the redirection + # stderr/stdout can be run with non-os handles in the call - + # but then it does introduce issues with terminal-detection and behaviour for stdout at least + # + # input is also a tee - we never want to change the source at this point - just log/process a side-channel of it. + # + #set id_in [shellfilter::stack::add $inchan tee_to_pipe -action sink-aside -settings [list -tag commandin -pipechan $inpipechan]] + + + #set id_out [shellfilter::stack::add stdout tee_to_log -action sink-aside -settings [list -tag shellstdout -syslog 127.0.0.1:514 -file ""]] + #set id_err [shellfilter::stack::add stderr tee_to_log -action sink-aside -settings [list -tag shellstderr -syslog 127.0.0.1:514 -file "stderr.txt"]] + + #we need to catch errors - and ensure stack::remove calls occur. + #An error can be raised if the command couldn't even launch, as opposed to a non-zero exitcode and stderr output from the command itself. + # + if {!$is_script} { + set experiment 0 + if {$experiment} { + try { + set results [exec {*}$commandlist] + set exitinfo [list exitcode 0] + } trap CHILDSTATUS {results options} { + set exitcode [lindex [dict get $options -errorcode] 2] + set exitinfo [list exitcode $exitcode] + } + } else { + if {[catch { + #run process with stdout/stderr/stdin or with configured channels + #set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan $inpipechan {*}$opts] + set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan stdin {*}$opts] + #puts stderr "---->exitinfo $exitinfo" + + #subprocess result should usually have an "exitcode" key + #but for background execution we will get a "pids" key of process ids. + } errMsg]} { + set exitinfo [list error "$errMsg" source shellcommand_stdout_stderr] + } + } + } else { + if {[catch { + #script result + set exitinfo [list result [uplevel #0 [list eval $commandlist]]] + } errMsg]} { + set exitinfo [list error "$errMsg" errorCode $::errorCode errorInfo "$::errorInfo"] + } + } + + + #the previous redirections on the underlying inchan/outchan/errchan items will be restored from the -aside setting during removal + #Remove execution-time Tees from stack + shellfilter::stack::remove stdout $id_out + shellfilter::stack::remove stderr $id_err + #shellfilter::stack::remove stderr $id_in + + + #chan configure stderr -buffering line + #flush stdout + + + ::shellfilter::log::write $runtag " return '$exitinfo'" + ::shellfilter::log::close $runtag + return $exitinfo + } + proc ::shellfilter::logtidyup { {tags {}} } { + variable sources + set worker_errorlist [list] + set tidied_sources [list] + set tidytag "logtidy" + + + # opening a thread or writing to a log/syslog close to possible process exit is probably not a great idea. + # we should ensure the thread already exists early on if we really need logging here. + # + #set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}] + #::shellfilter::log::write $tidytag " logtidyuptags '$tags'" + + foreach s $sources { + if {$s eq $tidytag} { + continue + } + #puts "logtidyup source $s" + set close 1 + if {[llength $tags]} { + if {$s ni $tags} { + set close 0 + } + } + if {$close} { + lappend tidied_sources $s + shellfilter::log::close $s + lappend worker_errorlist {*}[shellthread::manager::get_and_clear_errors $s] + } + } + set remaining_sources [list] + foreach s $sources { + if {$s ni $tidied_sources} { + lappend remaining_sources $s + } + } + + #set sources [concat $remaining_sources $tidytag] + set sources $remaining_sources + + #shellfilter::stack::unwind stdout + #shellfilter::stack::unwind stderr + return [list tidied $tidied_sources errors $worker_errorlist] + } + + #package require tcl::chan::null + # e.g set errchan [tcl::chan::null] + # e.g chan push stdout [shellfilter::chan::var new ::some_var] + proc ::shellfilter::shellcommand_stdout_stderr {commandlist outchan errchan inchan args} { + set valid_flags [list \ + -timeout \ + -outprefix \ + -errprefix \ + -debug \ + -copytempfile \ + -outbuffering \ + -errbuffering \ + -inbuffering \ + -readprocesstranslation \ + -outtranslation \ + -stdinhandler \ + -outchan \ + -errchan \ + -inchan \ + -teehandle\ + ] + + set runtag shellfilter-run2 + #JMN - load from config + #set tid [::shellfilter::log::open $runtag [list -syslog "127.0.0.1:514"]] + set tid [::shellfilter::log::open $runtag [list -syslog ""]] + + if {[llength $args] % 2} { + error "Trailing arguments after any positional arguments must be in pairs of the form -argname argvalue. Valid flags are:'$valid_flags'" + } + set invalid_flags [list] + foreach {k -} $args { + switch -- $k { + -timeout - + -outprefix - + -errprefix - + -debug - + -copytempfile - + -outbuffering - + -errbuffering - + -inbuffering - + -readprocesstranslation - + -outtranslation - + -stdinhandler - + -outchan - + -errchan - + -inchan - + -teehandle { + } + default { + lappend invalid_flags $k + } + } + } + if {[llength $invalid_flags]} { + error "Unknown option(s)'$invalid_flags': must be one of '$valid_flags'" + } + #line buffering generally best for output channels.. keeps relative output order of stdout/stdin closer to source order + #there may be data where line buffering is inappropriate, so it's configurable per std channel + #reading inputs with line buffering can result in extraneous newlines as we can't detect trailing data with no newline before eof. + set defaults [dict create \ + -outchan stdout \ + -errchan stderr \ + -inchan stdin \ + -outbuffering none \ + -errbuffering none \ + -readprocesstranslation auto \ + -outtranslation lf \ + -inbuffering none \ + -timeout 900000\ + -outprefix ""\ + -errprefix ""\ + -debug 0\ + -copytempfile 0\ + -stdinhandler ""\ + ] + + + + set args [dict merge $defaults $args] + set outbuffering [dict get $args -outbuffering] + set errbuffering [dict get $args -errbuffering] + set inbuffering [dict get $args -inbuffering] + set readprocesstranslation [dict get $args -readprocesstranslation] + set outtranslation [dict get $args -outtranslation] + set timeout [dict get $args -timeout] + set outprefix [dict get $args -outprefix] + set errprefix [dict get $args -errprefix] + set debug [dict get $args -debug] + set copytempfile [dict get $args -copytempfile] + set stdinhandler [dict get $args -stdinhandler] + + set debugname "shellfilter-debug" + + if {$debug} { + set tid [::shellfilter::log::open $debugname [list -syslog "127.0.0.1:514"]] + ::shellfilter::log::write $debugname " commandlist '$commandlist'" + } + #'clock micros' good enough id for shellcommand calls unless one day they can somehow be called concurrently or sequentially within a microsecond and within the same interp. + # a simple counter would probably work too + #consider other options if an alternative to the single vwait in this function is used. + set call_id [tcl::clock::microseconds] ; + set ::shellfilter::shellcommandvars($call_id,exitcode) "" + set ::shellfilter::shellcommandvars($call_id,timeoutid) "" + set waitvar ::shellfilter::shellcommandvars($call_id,waitvar) + if {$debug} { + ::shellfilter::log::write $debugname " waitvar '$waitvar'" + } + lassign [chan pipe] rderr wrerr + chan configure $wrerr -blocking 0 + + set custom_stderr "" + set lastitem [lindex $commandlist end] + #todo - ensure we can handle 2> file (space after >) + + #review - reconsider the handling of redirections such that tcl-style are handled totally separately to other shell syntaxes! + # + #note 2>@1 must ocur as last word for tcl - but 2@stdout can occur elsewhere + #(2>@stdout echoes to main stdout - not into pipeline) + #To properly do pipelines it looks like we will have to split on | and call this proc multiple times and wire it up accordingly (presumably in separate threads) + + switch -- [string trim $lastitem] { + {&} { + set name [lindex $commandlist 0] + #background execution - stdout and stderr from child still comes here - but process is backgrounded + #FIX! - this is broken for paths with backslashes for example + #set pidlist [exec {*}[concat $name [lrange $commandlist 1 end]]] + set pidlist [exec {*}$commandlist] + return [list pids $pidlist] + } + {2>&1} - {2>@1} { + set custom_stderr {2>@1} ;#use the tcl style + set commandlist [lrange $commandlist 0 end-1] + } + default { + # 2> filename + # 2>> filename + # 2>@ openfileid + set redir2test [string range $lastitem 0 1] + if {$redir2test eq "2>"} { + set custom_stderr $lastitem + set commandlist [lrange $commandlist 0 end-1] + } + } + } + set lastitem [lindex $commandlist end] + + set teefile "" ;#empty string, write, append + #an ugly hack.. because redirections seem to arrive wrapped - review! + #There be dragons here.. + #Be very careful with list manipulation of the commandlist string.. backslashes cause havoc. commandlist must always be a well-formed list. generally avoid string manipulations on entire list or accidentally breaking a list element into parts if it shouldn't be.. + #The problem here - is that we can't always know what was intended on the commandline regarding quoting + + ::shellfilter::log::write $runtag "checking for redirections in $commandlist" + #sometimes we see a redirection without a following space e.g >C:/somewhere + #normalize + switch -regexp -- $lastitem\ + {^>[/[:alpha:]]+} { + set lastitem "> [string range $lastitem 1 end]" + }\ + {^>>[/[:alpha:]]+} { + set lastitem ">> [string range $lastitem 2 end]" + } + + + #for a redirection, we assume either a 2-element list at tail of form {> {some path maybe with spaces}} + #or that the tail redirection is not wrapped.. x y z > {some path maybe with spaces} + #we can't use list methods such as llenth on a member of commandlist + set wordlike_parts [regexp -inline -all {\S+} $lastitem] + + if {([llength $wordlike_parts] >= 2) && ([lindex $wordlike_parts 0] in [list ">>" ">"])} { + #wrapped redirection - but maybe not 'well' wrapped (unquoted filename) + set lastitem [string trim $lastitem] ;#we often see { > something} + + #don't use lassign or lrange on the element itself without checking first + #we can treat the commandlist as a whole as a well formed list but not neccessarily each element within. + #lassign $lastitem redir redirtarget + #set commandlist [lrange $commandlist 0 end-1] + # + set itemchars [split $lastitem ""] + set firstchar [lindex $itemchars 0] + set lastchar [lindex $itemchars end] + + #NAIVE test for double quoted only! + #consider for example {"a" x="b"} + #testing first and last is not decisive + #We need to decide what level of drilling down is even appropriate here.. + #if something was double wrapped - it was perhaps deliberate so we don't interpret it as something(?) + set head_tail_chars [list $firstchar $lastchar] + set doublequoted [expr {[llength [lsearch -all $head_tail_chars "\""]] == 2}] + if {[string equal "\{" $firstchar] && [string equal "\}" $lastchar]} { + set curlyquoted 1 + } else { + set curlyquoted 0 + } + + if {$curlyquoted} { + #these are not the tcl protection brackets but ones supplied in the argument + #it's still not valid to use list operations on a member of the commandlist + set inner [string range $lastitem 1 end-1] + #todo - fix! we still must assume there could be list-breaking data! + set innerwords [regexp -inline -all {\S+} $inner] ;#better than [split $inner] because we don't get extra empty elements for each whitespace char + set redir [lindex $innerwords 0] ;#a *potential* redir - to be tested below + set redirtarget [lrange $innerwords 1 end] ;#all the rest + } elseif {$doublequoted} { + ::shellfilter::log::write $debugname "doublequoting at tail of command '$commandlist'" + set inner [string range $lastitem 1 end-1] + set innerwords [regexp -inline -all {\S+} $inner] + set redir [lindex $innerwords 0] + set redirtarget [lrange $innerwords 1 end] + } else { + set itemwords [regexp -inline -all {\S+} $lastitem] + # e.g > c:\test becomes > {c:\test} + # but > c/mnt/c/test/temp.txt stays as > /mnt/c/test/temp.txt + set redir [lindex $itemwords 0] + set redirtarget [lrange $itemwords 1 end] + } + set commandlist [lrange $commandlist 0 end-1] + + } elseif {[lindex $commandlist end-1] in [list ">>" ">"]} { + #unwrapped redirection + #we should be able to use list operations like lindex and lrange here as the command itself is hopefully still a well formed list + set redir [lindex $commandlist end-1] + set redirtarget [lindex $commandlist end] + set commandlist [lrange $commandlist 0 end-2] + } else { + #no redirection + set redir "" + set redirtarget "" + #no change to command list + } + + + switch -- $redir { + ">>" - ">" { + set redirtarget [string trim $redirtarget "\""] + ::shellfilter::log::write $runtag " have redirection '$redir' to '$redirtarget'" + + set winfile $redirtarget ;#default assumption + switch -glob -- $redirtarget { + "/c/*" { + set winfile "c:/[string range $redirtarget 3 end]" + } + "/mnt/c/*" { + set winfile "c:/[string range $redirtarget 7 end]" + } + } + + if {[file exists [file dirname $winfile]]} { + #containing folder for target exists + if {$redir eq ">"} { + set teefile "write" + } else { + set teefile "append" + } + ::shellfilter::log::write $runtag "Directory exists '[file dirname $winfile]' operation:$teefile" + } else { + #we should be writing to a file.. but can't + ::shellfilter::log::write $runtag "cannot verify directory exists '[file dirname $winfile]'" + } + } + default { + ::shellfilter::log::write $runtag "No redir found!!" + } + } + + #often first element of command list is wrapped and cannot be run directly + #e.g {{ls -l} {> {temp.tmp}}} + #we will assume that if there is a single element which is a pathname containing a space - it is doubly wrapped. + # this may not be true - and the command may fail if it's just {c:\program files\etc} but it is the less common case and we currently have no way to detect. + #unwrap first element.. will not affect if not wrapped anyway (subject to comment above re spaces) + set commandlist [concat [lindex $commandlist 0] [lrange $commandlist 1 end]] + + #todo? + #child process environment. + # - to pass a different environment to the child - we would need to save the env array, modify as required, and then restore the env array. + + #to restore buffering states after run + set remember_in_out_err_buffering [list \ + [chan configure $inchan -buffering] \ + [chan configure $outchan -buffering] \ + [chan configure $errchan -buffering] \ + ] + + set remember_in_out_err_translation [list \ + [chan configure $inchan -translation] \ + [chan configure $outchan -translation] \ + [chan configure $errchan -translation] \ + ] + + + + + #chan configure $inchan -buffering none -blocking 1 ;#test + chan configure $inchan -buffering $inbuffering -blocking 0 ;#we are setting up a readable handler for this - so non-blocking ok + + + chan configure $errchan -buffering $errbuffering + #chan configure $outchan -blocking 0 + chan configure $outchan -buffering $outbuffering ;#don't configure non-blocking. weird duplicate of *second* line occurs if you do. + # + + #-------------------------------------------- + #Tested on windows. Works to stop in output when buffering is none, reading from channel with -translation auto + #cmd, pwsh, tcl + #chan configure $outchan -translation lf + #chan configure $errchan -translation lf + #-------------------------------------------- + chan configure $outchan -translation $outtranslation + chan configure $errchan -translation $outtranslation + + #puts stderr "chan configure $wrerr [chan configure $wrerr]" + if {$debug} { + ::shellfilter::log::write $debugname "COMMAND [list $commandlist] strlen:[string length $commandlist] llen:[llength $commandlist]" + } + #todo - handle custom redirection of stderr to a file? + if {[string length $custom_stderr]} { + #::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist $custom_stderr] a+" + #set rdout [open |[concat $commandlist $custom_stderr] a+] + ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list $custom_stderr <@$inchan]] [list RDONLY]" + set rdout [open |[concat $commandlist [list <@$inchan $custom_stderr]] [list RDONLY]] + set rderr "bogus" ;#so we don't wait for it + } else { + ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]" + #set rdout [open |[concat $commandlist [list 2>@$wrerr]] a+] + #set rdout [open |[concat $commandlist [list 2>@$wrerr]] [list RDWR]] + + # If we don't redirect stderr to our own tcl-based channel - then the transforms don't get applied. + # This is the whole reason we need these file-event loops. + # Ideally we need something like exec,open in tcl that interacts with transformed channels directly and emits as it runs, not only at termination + # - and that at least appears like a terminal to the called command. + #set rdout [open |[concat $commandlist [list 2>@stderr <@$inchan]] [list RDONLY]] + + #REVIEW! + #if the child process takes a while to begin reading stdin - the data on stdin between when we stopped the parent chan event handler and when the child gets data, + #seems to stay buffered somewhere. It is then read by the parent, after the child returns. (ie not lost, but out-of-order) + #This can be apparent sometimes even with fast typing upon calling an executable. (e.g occasionally even vim - but seems to be timing based so might only happen first time if at all) + # see scriptlib/stdin_race.tcl etc test files. + #similar problem with python & perl - issue seems to be in libc or OS buffering behaviour for standard channels. + #note that zig (repo/jn/zig/stdin_race) seems to avoid this issue - todo - make zig based binary extension for open/exec? + + set rdout [open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]] + + chan configure $rderr -buffering $errbuffering -blocking 0 + chan configure $rderr -translation $readprocesstranslation + } + + + + set command_pids [pid $rdout] + #puts stderr "command_pids: $command_pids" + #tcl::process ensemble only available in 8.7+ - and it didn't prove useful here anyway + # the child process generally won't shut down until channels are closed. + # premature EOF on grandchild process launch seems to be due to lack of terminal emulation when redirecting stdin/stdout. + # worked around in punk/repl using 'script' command as a fake tty. + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $command_pids 0] ni $subprocesses} { + # puts stderr "pid [lindex $command_pids 0] not running $errMsg" + #} else { + # puts stderr "pid [lindex $command_pids 0] is running" + #} + + + if {$debug} { + ::shellfilter::log::write $debugname "pipeline pids: $command_pids" + } + + #jjj + + + chan configure $rdout -buffering $outbuffering -blocking 0 + chan configure $rdout -translation $readprocesstranslation + + if {![string length $custom_stderr]} { + chan event $rderr readable [list apply {{chan other wrerr outchan errchan waitfor errprefix errbuffering debug debugname pids} { + if {$errbuffering eq "line"} { + set countchunk [chan gets $chan chunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + #errprefix only applicable to line buffered output + if {$countchunk >= 0} { + if {[chan eof $chan]} { + puts -nonewline $errchan ${errprefix}$chunk + } else { + puts $errchan "${errprefix}$chunk" + } + } + } else { + set chunk [chan read $chan] + if {[string length $chunk]} { + puts -nonewline $errchan $chunk + } + } + if {[chan eof $chan]} { + flush $errchan ;#jmn + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $pids 0] ni $subprocesses} { + # puts stderr "stderr reader: pid [lindex $pids 0] no longer running" + #} else { + # puts stderr "stderr reader: pid [lindex $pids 0] still running" + #} + chan close $chan + #catch {chan close $wrerr} + #if {$other ni [chan names]} { + # set $waitfor stderr + #} + if {[catch {chan configure $other}]} { + set $waitfor stderr + } + } + }} $rderr $rdout $wrerr $outchan $errchan $waitvar $errprefix $errbuffering $debug $debugname $command_pids] + } + + #todo - handle case where large amount of stdin coming in faster than rdout can handle + #as is - arbitrary amount of memory could be used because we aren't using a filevent for rdout being writable + # - we're just pumping it in to the non-blocking rdout buffers + # ie there is no backpressure and stdin will suck in as fast as possible. + # for most commandlines this probably isn't too big a deal.. but it could be a problem for multi-GB disk images etc + # + # + + ## Note - detecting trailing missing nl before eof is basically the same here as when reading rdout from executable + # - but there is a slight difference in that with rdout we get an extra blocked state just prior to the final read. + # Not known if that is significant + ## with inchan configured -buffering line + #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl -r cat + #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl -r cat + #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:1 pend:-1 count:3 + #etc + + if 0 { + chan event $inchan readable [list apply {{chan wrchan inbuffering waitfor} { + #chan copy stdin $chan ;#doesn't work in a chan event + if {$inbuffering eq "line"} { + set countchunk [chan gets $chan chunk] + #puts $wrchan "stdinstate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + if {$countchunk >= 0} { + if {[chan eof $chan]} { + puts -nonewline $wrchan $chunk + } else { + puts $wrchan $chunk + } + } + } else { + set chunk [chan read $chan] + if {[string length $chunk]} { + puts -nonewline $wrchan $chunk + } + } + if {[chan eof $chan]} { + puts stderr "|stdin_reader>eof [chan configure stdin]" + chan event $chan readable {} + #chan close $chan + chan close $wrchan write ;#half close + #set $waitfor "stdin" + } + }} $inchan $rdout $inbuffering $waitvar] + + if {[string length $stdinhandler]} { + chan configure stdin -buffering line -blocking 0 + chan event stdin readable $stdinhandler + } + } + + set actual_proc_out_buffering [chan configure $rdout -buffering] + set actual_outchan_buffering [chan configure $outchan -buffering] + #despite whatever is configured - we match our reading to how we need to output + set read_proc_out_buffering $actual_outchan_buffering + + + + if {[string length $teefile]} { + set logname "redir_[string map {: _} $winfile]_[tcl::clock::microseconds]" + set tid [::shellfilter::log::open $logname {-syslog 127.0.0.1:514}] + if {$teefile eq "write"} { + ::shellfilter::log::write $logname "opening '$winfile' for write" + set fd [open $winfile w] + } else { + ::shellfilter::log::write $logname "opening '$winfile' for appending" + set fd [open $winfile a] + } + #chan configure $fd -translation lf + chan configure $fd -translation $outtranslation + chan configure $fd -encoding utf-8 + + set tempvar_bytetotal [namespace current]::totalbytes[tcl::clock::microseconds] + set $tempvar_bytetotal 0 + chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname writefile writefilefd copytempfile bytevar logtag} { + #review - if we write outprefix to normal stdout.. why not to redirected file? + #usefulness of outprefix is dubious + upvar $bytevar totalbytes + if {$read_proc_out_buffering eq "line"} { + #set outchunk [chan read $chan] + set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + if {$countchunk >= 0} { + if {![chan eof $chan]} { + set numbytes [expr {[string length $outchunk] + 1}] ;#we are assuming \n not \r\n - but count won't/can't be completely accurate(?) - review + puts $writefilefd $outchunk + } else { + set numbytes [string length $outchunk] + puts -nonewline $writefilefd $outchunk + } + incr totalbytes $numbytes + ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" + #puts $outchan "${outprefix} wrote $numbytes bytes to $writefile" + } + } else { + set outchunk [chan read $chan] + if {[string length $outchunk]} { + puts -nonewline $writefilefd $outchunk + set numbytes [string length $outchunk] + incr totalbytes $numbytes + ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" + } + } + if {[chan eof $chan]} { + flush $writefilefd ;#jmn + #set blocking so we can get exit code + chan configure $chan -blocking 1 + catch {::shellfilter::log::write $logtag "${outprefix} total bytes $totalbytes written to $writefile"} + #puts $outchan "${outprefix} total bytes $totalbytes written to $writefile" + catch {close $writefilefd} + if {$copytempfile} { + catch {file copy $writefile "[file rootname $writefile]_copy[file extension $writefile]"} + } + try { + chan close $chan + set ::shellfilter::shellcommandvars($call_id,exitcode) 0 + if {$debug} { + ::shellfilter::log::write $debugname "(teefile) -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + if {$debug} { + ::shellfilter::log::write $debugname "(teefile) CHILD PROCESS EXITED with code: $code" + } + set ::shellfilter::shellcommandvars($call_id,exitcode) $code + } + catch {chan close $wrerr} + #if {$other ni [chan names]} { + # set $waitfor stdout + #} + if {[catch {chan configure $other}]} { + set $waitfor stdout + } + } + }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $winfile $fd $copytempfile $tempvar_bytetotal $logname] + + } else { + + # This occurs when we have outbuffering set to 'line' - as the 'input' from rdout which comes from the executable is also configured to 'line' + # where b:0|1 is whether chan blocked $chan returns 0 or 1 + # pend is the result of chan pending $chan + # eof is the resot of chan eof $chan + + + ##------------------------- + ##If we still read with gets,to retrieve line by line for output to line-buffered output - but the input channel is configured with -buffering none + ## then we can detect the difference + # there is an extra blocking read - but we can stil use eof with data to detect the absent newline and avoid passing an extra one on. + #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /u/c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:1 eof:0 pend:-1 count:-1 + #instate b:0 eof:1 pend:-1 count:3 + #etc + ##------------------------ + + + #this should only occur if upstream is coming from stdin reader that has line buffering and hasn't handled the difference properly.. + ###reading with gets from line buffered input with trailing newline + #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + ###reading with gets from line buffered input with trailing newline + ##No detectable difference! + #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + ##------------------------- + + #Note that reading from -buffering none and writing straight out gives no problem because we pass the newlines through as is + + + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($rdout) 0 ;#a very specific case of readblocked prior to eof.. possibly not important + #this detection is disabled for now - but left for debugging in case it means something.. or changes + chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname pids} { + #set outchunk [chan read $chan] + + if {$read_proc_out_buffering eq "line"} { + set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + #countchunk can be -1 before eof e.g when blocked + #debugging output inline with data - don't leave enabled + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + if {$countchunk >= 0} { + if {![chan eof $chan]} { + puts $outchan ${outprefix}$outchunk + } else { + puts -nonewline $outchan ${outprefix}$outchunk + #if {$::shellfilter::chan::lastreadblocked_nodata_noeof($chan)} { + # seems to be the usual case + #} else { + # #false alarm, or ? we've reached eof with data but didn't get an empty blocking read just prior + # #Not known if this occurs + # #debugging output inline with data - don't leave enabled + # puts $outchan "!!!prev read didn't block: instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + #} + } + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) 0 + } else { + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) [expr {[chan blocked $chan] && ![chan eof $chan]}] + } + } else { + #puts $outchan "read CHANNEL $chan [chan configure $chan]" + #puts $outchan "write CHANNEL $outchan b:[chan configure $outchan -buffering] t:[chan configure $outchan -translation] e:[chan configure $outchan -encoding]" + set outchunk [chan read $chan] + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:[string length $outchunk]" + if {[string length $outchunk]} { + #set stringrep [encoding convertfrom utf-8 $outchunk] + #set newbytes [encoding convertto utf-16 $stringrep] + #puts -nonewline $outchan $newbytes + puts -nonewline $outchan $outchunk + } + } + + if {[chan eof $chan]} { + flush $outchan ;#jmn + #for now just look for first element in the pid list.. + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $pids 0] ni $subprocesses} { + # puts stderr "stdout reader pid: [lindex $pids 0] no longer running" + #} else { + # puts stderr "stdout reader pid: [lindex $pids 0] still running" + #} + + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan]" + chan configure $chan -blocking 1 ;#so we can get exit code + try { + chan close $chan + set ::shellfilter::shellcommandvars($call_id,exitcode) 0 + if {$debug} { + ::shellfilter::log::write $debugname " -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + set ::shellfilter::shellcommandvars($call_id,exitcode) $code + if {$debug} { + ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with code: $code" + } + } trap CHILDKILLED {result options} { + #set code [lindex [dict get $options -errorcode] 2] + #set ::shellfilter::shellcommandvars(%id%,exitcode) $code + set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled" + if {$debug} { + ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with result:'$result' options:'$options'" + } + + } finally { + #puts stdout "HERE" + #flush stdout + + } + catch {chan close $wrerr} + #if {$other ni [chan names]} { + # set $waitfor stdout + #} + if {[catch {chan configure $other}]} { + set $waitfor stdout + } + + } + }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $command_pids] + } + + #todo - add ability to detect activity/data-flow and change timeout to only apply for period with zero data + #e.g x hrs with no data(?) + #reset timeout when data detected. + #review - stdin??? + set ::shellfilter::shellcommandvars($call_id,timeoutid) [after $timeout [string map [list %cpids% $command_pids %w% $waitvar %id% $call_id %wrerr% $wrerr %rdout% $rdout %rderr% $rderr %debug% $debug %debugname% $debugname] { + if {[info exists ::shellfilter::shellcommandvars(%id%,exitcode)]} { + #killing the task (on windows) doesn't seem to work if done after we close the output channels + catch {puts stderr "timeout - closing.";flush stderr} + set command_pids "{%cpids%}" + if {[llength $command_pids]} { + set pid [lindex $command_pids 0] + if {$::tcl_platform(platform) eq "windows"} { + set killcmd [list [auto_execok taskkill] /F /PID $pid] + } else { + #set killcmd [list kill -9 $pid] + set killcmd [list kill -TERM $pid] + } + if {[catch { + exec {*}$killcmd + } errM]} { + puts stderr "Failed to kill '$pid': errMsg $errM" + flush stderr + } + } + if {[set ::shellfilter::shellcommandvars(%id%,exitcode)] ne ""} { + catch { chan close %wrerr% } + catch { chan close %rdout%} + catch { chan close %rderr%} + } else { + chan configure %rdout% -blocking 1 + try { + chan close %rdout% + set ::shellfilter::shellcommandvars(%id%,exitcode) 0 + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) CHILD PROCESS EXITED with code: $code" + } + set ::shellfilter::shellcommandvars(%id%,exitcode) $code + } trap CHILDKILLED {result options} { + set code [lindex [dict get $options -errorcode] 2] + #set code [dict get $options -code] + #set ::shellfilter::shellcommandvars(%id%,exitcode) $code + #set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled-timeout" + set ::shellfilter::shellcommandvars(%id%,exitcode) "childkilled-timeout" + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) CHILDKILLED with code: $code" + ::shellfilter::log::write %debugname% "(timeout) result:$result options:$options" + } + + } + catch { chan close %wrerr% } + catch { chan close %rderr%} + } + set %w% "timeout" + } + }]] + + + vwait $waitvar + after cancel $::shellfilter::shellcommandvars($call_id,timeoutid) + + #puts stderr "waitvar:[set $waitvar]" + #flush stderr + #if {[set $waitvar] eq "timeout"} { + # #note: attempting to kill a process here (after channels closed) doesn't work (on windows at least) + # puts stderr "command_pids: $command_pids" + # flush stderr + #} + + set exitcode [set ::shellfilter::shellcommandvars($call_id,exitcode)] + if {![string is digit -strict $exitcode]} { + puts stderr "Process exited with non-numeric code: $exitcode closed_by:[set $waitvar]" + flush stderr + } + if {[string length $teefile]} { + #cannot be called from within an event handler above.. vwait reentrancy etc + catch {::shellfilter::log::close $logname} + } + + if {$debug} { + ::shellfilter::log::write $debugname " closed by: [set $waitvar] with exitcode: $exitcode" + catch {::shellfilter::log::close $debugname} + } + array unset ::shellfilter::shellcommandvars $call_id,* + + + #restore buffering to pre shellfilter::run state + lassign $remember_in_out_err_buffering bin bout berr + chan configure $inchan -buffering $bin + chan configure $outchan -buffering $bout + chan configure $errchan -buffering $berr + + lassign $remember_in_out_err_translation tin tout terr + chan configure $inchan -translation $tin + chan configure $outchan -translation $tout + chan configure $errchan -translation $terr + + + #in channel probably closed..(? review - should it be?) + catch { + chan configure $inchan -buffering $bin + } + + + return [list exitcode $exitcode] + } + +} + +package provide shellfilter [namespace eval shellfilter { + variable version + set version 0.2.1 +}]