From 0bf6f7401e13d95f1e8beb447f7c70f04d285480 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Thu, 4 May 2023 17:20:17 +1000 Subject: [PATCH] x,y= work prior to implementation of .= explicit execution feature --- src/modules/punk-0.1.tm | 551 +++++++++++++- src/modules/shellfilter-0.1.8.tm | 4 +- src/modules/shellrun-0.1.tm | 173 ++++- src/punk86.vfs/lib/app-punk/repl.tcl | 714 ++++++++++++++----- src/punk86.vfs/lib/app-shellspy/shellspy.tcl | 1 + 5 files changed, 1201 insertions(+), 242 deletions(-) diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index b29c1b56..e8df5e78 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -3,6 +3,10 @@ package provide punk [namespace eval punk { set version 0.1 }] +#cooperative withe punk repl +namespace eval ::repl { + variable running 0 +} namespace eval punk::config { variable loaded variable startup ;#include env overrides @@ -73,6 +77,330 @@ namespace eval punk::config { } namespace eval punk { + variable last_run_display [list] + variable ansi_disabled 0 + variable re_headvar1 {([a-zA-Z:@.(),]+?)(?![^(]*\))(,.*)*$} + variable re_headvar {(.+?)(?![^(]*\))(,.*)*$} + proc ::punk::var {varname {= {}} args} { + if {${=} == "="} { + if {[llength $args] > 1} { + uplevel 1 [list set $varname [uplevel 1 $args]] + } else { + uplevel 1 [list set $varname [lindex $args 0]] + } + } else { + uplevel 1 [list set $varname] + } + } + proc know {cond body} { + set existing [info body ::unknown] + #assuming we can't test on cond being present - because it may be fairly simple and prone to false positives (?) + ##This means we can't have 2 different conds with same body. Not a big drawback. + #if {$body ni $existing} { + proc ::unknown {args} [string map [list @c@ $cond @b@ $body] { + #--------------------------------------- + if {![catch {expr {@c@}} res] && $res} { + return [eval {@b@}] + } + #--------------------------------------- + }]$existing + #} + } + proc know? {} { + puts [string range [info body ::unknown] 0 1811] + } + + #split a varname of form var1,var2,var3.. at commas - but ignoring commas within brackets (a common array variable convention). + #e.g var(x,y),blah,var(,foo) would be split into var(x,y) blah var(,foo) + proc _split_at_unbracketed_commas {varname} { + set varname [string trimleft $varname ,] + variable re_headvar + set varlist [list] + if {[regexp $re_headvar $varname _ v1 vtail]} { + lappend varlist $v1 + set subvars [_split_at_unbracketed_commas $vtail] + set varlist [concat $varlist $subvars] + return $varlist + } else { + return $varname + } + } + + + #called from know_assign - uplevel 2 to caller's level + proc _multi_assign_expression_result {multivar expression1 {unset 0}} { + set lvlup 2 + set varspeclist [_split_at_unbracketed_commas $multivar] + set vidx 0 + foreach vspec $varspeclist { + set firstat [string first "@" $vspec] + if {$firstat > 0} { + set v [string range $vspec 0 $firstat-1] + if {[string is integer -strict $v]} { + error "Cannot set a var named '$v' using this syntax. use == for comparison, or use set $v if you really want a variable named like a number." + } + if {$unset} { + uplevel $lvlup [list unset $v] + continue + } + + set part2 [string range $vspec $firstat+1 end] + if {$part2 eq ""} { + set v [string range $vspec 0 end-1] + #no dict key following @, this is a positional spec + uplevel $lvlup [list set $v [lindex $expression1 $vidx]] + incr vidx ;#only incr each time we have a trailing @ + } elseif {[string match "@*" $part2]} { + # varname@@ = last element + # varname@@x where x is positive or negative integer or zero - use x as lindex + # or x is a range e.g 0-3 suitable for lrange + set selector [string range $part2 1 end] + if {([string is integer -strict $selector]) || ([regexp {^(end)$|^end[-+]{1,2}([0-9]+)$} $selector])} { + uplevel $lvlup [list set $v [lindex $expression1 $selector]] + } elseif {[regexp {^([0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $selector _ start end]} { + uplevel $lvlup [list set $v [lrange $expression1 $start $end]] + } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $selector _ start end]} { + uplevel $lvlup [list set $v [lrange $expression1 $start $end]] + } else { + error "Unable to interpret $vspec @@ must be followed by index suitable for lindex or lrange commands" + } + } else { + set key $part2 + #part following a single @ is dict key + if {[dict exists $expression1 $key]} { + uplevel $lvlup [list set $v [dict get $expression1 $key]] + } else { + #for consistency with lindex out of range setting var to empty string - we will do same for non existent dict key rather than unset + uplevel $lvlup [list set $v ""] + #catch { + # uplevel $lvlup [list unset $v] + #} + } + } + } else { + set v $vspec + if {[string is integer -strict $v]} { + error "Cannot set a var named '$v' using this syntax. use == for comparison, or use set $v if you really want a variable named like a number." + } + if {$unset} { + uplevel $lvlup [list unset $v] + continue + } + uplevel $lvlup [list set $v $expression1] + } + } + } + + + #know_assign is tailcalled from unknown - uplevel 1 gets to caller level + proc know_assign {multivar expression1 tail} { + if {$::repl::running} { + #todo - debugrepl? + ::repl::rputs stderr "# '$multivar' '$expression1' '$tail'" + } + if {[string is integer -strict $multivar]} { + error "Cannot set a var named '$multivar' using this syntax. use == for comparison, or use set $multivar if you really want a variable named like a number." + } + + puts stderr "tail len: [llength $tail]" + puts stderr "tail-end: [lindex $tail end]" + + if {![string length [string trim $expression1]]} { + if {[llength $tail] > 0} { + #error "unexpected args following =. use 'var=' to unset var or spaced expression e.g 'var=1 + 2'" + if {![catch {expr {*}$tail} evaluated]} { + _multi_assign_expression_result $multivar $evaluated + #return [uplevel 1 [list set $multivar $evaluated]] + return $evaluated + } + #set result [string cat {*}$tail] ;#not very useful + set result $tail + + _multi_assign_expression_result $multivar $result + #return [uplevel 1 [list set $multivar [string cat {*}$tail]]] + return $result + } + _multi_assign_expression_result $multivar "" 1 ;#final arg 1 to unset variables + #uplevel 1 [list unset $multivar] + return + } elseif {[llength $tail] == 0} { + #simple value assignment - even if it looks like an expression + #ie x=4+1 assigns "4+1" as a string + #whereas x=4 + 1 assigns 5 + #set commaparts [split $var ,] + _multi_assign_expression_result $multivar $expression1 + return $expression1 + } elseif {![catch {expr $expression1 {*}$tail} evaluated]} { + puts stderr ">evaluated $expression1 {*}$tail as expression" + + _multi_assign_expression_result $multivar $evaluated + #return [uplevel 1 [list set $var $evaluated]] + return $evaluated + } else { + puts stderr ">>expression: $expression1" + set leader [string index $expression1 0] + if {$leader in [list \" \{ ]} { + set expression1 [string range $expression1 1 end] + set newtail [list] + foreach block $tail { + set b [linelist $block] + lappend newtail $b + } + set tail $newtail + } + #set expression1 [string trimleft $expression1 \"] + #set expression1 [string trimleft $expression1 \{] + + set build "" + set cmdstr "" + set wordlike_parts [regexp -inline -all {\S+} "$expression1 $tail"] + foreach t $wordlike_parts { + set t [string trim $t \"] + if {![string length $build]} { + if {[info complete $t]} { + append cmdstr " $t" + continue + } + } + + append build " $t" + if {[info complete $build]} { + #append cmdstr " [string trim $build \"]" + append cmdstr $build + set build "" + } + } + #set result [uplevel 1 $cmdstr] + #set result [uplevel 1 [concat $expression1 $tail]] + #set result [uplevel 1 [$expression1 {*}$tail]] + if {$leader in [list \" \{ ]} { + #?? + puts stderr ">>>uplevel 1 [concat $expression1 $tail]" + set result [uplevel 1 [concat $expression1 $tail]] + # + #set result [linelist $result] + puts stderr "-- '$result'" + _multi_assign_expression_result $multivar $result + } else { + puts stderr ">no leader" + set result [uplevel 1 [concat $expression1 $tail]] + puts stderr "-- '$result'" + _multi_assign_expression_result $multivar $result + } + #return [uplevel 1 [list set $multivar [uplevel 1 [concat $expression1 $tail]]]] + return $result + } + } + + proc configure_unknown {} { + #----------------------------- + #these are critical e.g core behaviour or important for repl displaying output correctly + + #---------------- + #for var="val {a b c}" + proc ::punk::arg {arg} {return $arg} + proc ::punk::val {v} {tailcall lindex $v} + #---------------- + + #can't use know - because we don't want to return before original unknown body is called. + proc ::unknown {args} [string map [list] { + set ::punk::last_run_display [list] + set ::repl::last_unknown [lindex $args 0] ;#jn + }][info body ::unknown] + + + #handle process return dict of form {exitcode num etc blah} + #ie when the return result as a whole is treated as a command + #exitcode must be the first key + know {[lindex $args 0 0] eq "exitcode"} { + uplevel 1 [list exitcode {*}[lrange [lindex $args 0] 1 end]] + } + #----------------------------- + # + # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. + + know {[expr $args] || 1} { + #todo - repl output info that it was evaluated as an expression + expr $args + } + + know {[regexp {^([0-9]+)\.\.([0-9]+)$} [lindex $args 0] -> from to]} { + set res {} + while {$from<=$to} {lappend res $from; incr from} + set res + } + #if {[info proc ::punk::_unknown] eq ""} {rename unknown ::punk::_unknown} + + know {[regexp {([^=]*)=(.*)} [lindex $args 0] _ var expression1]} { + if {![string length $var]} { + error "usage var=val Var cannot be empty string using this syntax. Use ''set {} val' if you want to set a var with an empty-string name" + } + set tail [lrange $args 1 end] + tailcall ::punk::know_assign $var $expression1 $tail + } + #ensure == is after = in know sequence + know {[regexp {(.*)==(.*)} [lindex $args 0] _ val1 val2]} { + if {![string length [string trim $val2]]} { + if {[llength $args] > 1} { + #error "Extra args after comparison operator ==. usage e.g : \$var1==\$var2 or \$var1==\$var2 + 2" + set val2 [string cat {*}[lrange $args 1 end]] + return [expr {$val1 eq $val2}] + } + return $val1 + } elseif {[llength $args] == 1} { + #simple comparison + if {[string is digit -strict $val1$val2]} { + return [expr {$val1 == $val2}] + } else { + return [string equal $val1 $val2] + } + } elseif {![catch {expr $val2 {*}[lrange $args 1 end]} evaluated]} { + if {[string is digit -strict $val1$evaluated]} { + return [expr {$val1 == $evaluated}] + } else { + return [expr {$val1 eq $evaluated}] + } + } else { + set evaluated [uplevel 1 [list {*}$val2 {*}[lrange $args 1 end]]] + if {[string is digit -strict $val1$evaluated]} { + return [expr {$val1 == $evaluated}] + } else { + return [expr {$val1 eq $evaluated}] + } + } + } + know {[regexp {^=([^=]*)} [lindex $args 0] _ v1]} { + set calc [concat $v1 [lrange $args 1 end]] + puts stderr "= $calc" + return [expr $calc] + } + + } + configure_unknown + #if client redefines 'unknown' after package require punk, they must call punk::configure_unknown afterwords. + + proc ansi+ {args} { + variable ansi_disabled + if {$ansi_disabled == 1} { + return + } + tailcall ::shellfilter::ansi::+ {*}$args + } + proc ansi {{onoff {}}} { + variable ansi_disabled + if {[string length $onoff]} { + set onoff [string tolower $onoff] + if {$onoff in [list 1 on true yes]} { + set ansi_disabled 0 + } elseif {$onoff in [list 0 off false no]} { + set ansi_disabled 1 + } else { + error "punk::ansi expected 0|1|on|off|true|false|yes|no" + } + } + catch {repl::reset_prompt} + return [expr {!$ansi_disabled}] + } proc scriptlibpath {{shortname {}} args} { upvar ::punk::config::running running_config set scriptlib [dict get $running_config scriptlib] @@ -110,7 +438,11 @@ namespace eval punk { } #useful for aliases e.g treemore -> xmore tree proc xmore {args} { - {*}$args | more + if {[llength $args]} { + {*}$args | more + } else { + error "usage: punk::xmore args where args are run as {*}\$args | more" + } } proc winpath {path} { #convert /c/etc to C:/etc @@ -341,14 +673,17 @@ namespace eval punk { if {![llength $args]} { - set out [runout -n ls -aFC] - #puts stdout $out - #puts stderr [a+ white]$out[a+] - set result [pwd] - set chunklist [list] - lappend chunklist [list stderr "[a+ white light]$out[a+]\n"] - lappend chunklist [list stdout $result\n] - set ::punk::last_run_display $chunklist + set out [runout -n ls -aFC] + #puts stdout $out + #puts stderr [a+ white]$out[a+] + set result [pwd] + set chunklist [list] + lappend chunklist [list stdout "[a+ white light]$out[a+]\n"] + lappend chunklist [list result $result] + set ::punk::last_run_display $chunklist + if {$::repl::running} { + repl::term::set_console_title [file normalize $result] + } return $result } else { set a1 [lindex $args 0] @@ -382,17 +717,21 @@ namespace eval punk { proc ../ {args} { set ::punk::last_run_display [list] if {![llength $args]} { - cd .. + set path .. } else { - cd ../[file join {*}$args] + set path ../[file join {*}$args] } + cd $path set out [runout -n ls -aFC] set result [pwd] #return $out\n[pwd] set chunklist [list] - lappend chunklist [list stderr "[a+ white light]$out[a+]\n"] - lappend chunklist [list stdout $result\n] + lappend chunklist [list stdout "[a+ white light]$out[a+]\n"] + lappend chunklist [list result $result] set ::punk::last_run_display $chunklist + if {$::repl::running} { + repl::term::term::set_console_title $result + } return $result } proc ls {args} { @@ -413,13 +752,139 @@ namespace eval punk { } proc cdwin {path} { set path [punk::winpath $path] + if {$::repl::running} { + repl::term::term::set_console_title $path + } cd $path } proc cdwindir {path} { set path [punk::winpath $path] + if {$::repl::running} { + repl::term::set_console_title $path + } cd [file dirname $path] } + #like linelist - but keeps leading and trailing empty lines + #single \n produces {} {} + #the result can be joined to reform the arg if a single arg supplied + # + proc linelistraw {args} { + set linelist [list] + foreach {a} $args { + set nsplit [split $a \n] + lappend linelist {*}$nsplit + } + #return [split $text \n] + return $linelist + } + proc linelist1 {args} { + set linelist [list] + foreach {a} $args { + set nsplit [split $a \n] + set start 0 + set end "end" + + if {[lindex $nsplit 0] eq ""} { + set start 1 + } + if {[lindex $nsplit end] eq ""} { + set end "end-1" + } + set alist [lrange $nsplit $start $end] + lappend linelist {*}$alist + } + return $linelist + } + # + proc linelist {text} { + set linelist [list] + if {[string first \n $text] < 0} { + return $text + } + set nsplit [split $text \n] + set start 0 + set end "end" + if {[lindex $nsplit 0] eq ""} { + set start 1 + } + if {[lindex $nsplit end] eq ""} { + set end "end-1" + } + set alist [lrange $nsplit $start $end] + lappend linelist {*}$alist + return $linelist + } + #linedict based on indents + proc linedict {args} { + set data [lindex $args 0] + set opts [lrange $args 1 end] ;#todo + set nsplit [split $data \n] + set rootindent -1 + set stepindent -1 + + #set wordlike_parts [regexp -inline -all {\S+} $lastitem] + set d [dict create] + set keys [list] + set i 1 + set firstkeyline "N/A" + set firststepline "N/A" + foreach ln $nsplit { + if {![string length [string trim $ln]]} { + incr i + continue + } + set is_rootkey 0 + regexp {(\s*)(.*)} $ln _ space linedata + puts stderr ">>line:'$ln' [string length $space] $linedata" + set this_indent [string length $space] + if {$rootindent < 0} { + set firstkeyline $ln + set rootindent $this_indent + } + if {$this_indent == $rootindent} { + set is_rootkey 1 + } + if {$this_indent < $rootindent} { + error "bad root indentation ($this_indent) at line: $i smallest indent was set by first key line: $firstkeyline" + } + if {$is_rootkey} { + dict set d $linedata {} + lappend keys $linedata + } else { + if {$stepindent < 0} { + set stepindent $this_indent + set firststepline $ln + } + if {$this_indent == $stepindent} { + dict set d [lindex $keys end] $ln + } else { + if {($this_indent % $stepindent) != 0} { + error "bad indentation ($this_indent) at line: $i not a multiple of the first key indent $step_indent seen on $firststepline" + } + + #todo fix! + set parentkey [lindex $keys end] + lappend keys [list $parentkey $ln] + set oldval [dict get $d $parentkey] + if {[string length $oldval]} { + set new [dict create $oldval $ln] + } else { + dict set d $parentkey $ln + } + + } + } + incr i + } + return $d + } + proc dictline {d} { + puts stderr "unimplemented" + set lines [list] + + return $lines + } #return list of {chan chunk} elements proc help_chunks {} { set chunks [list] @@ -464,20 +929,40 @@ namespace eval punk { #current interp aliases except those created by pattern package '::p::*' proc aliases {{glob *}} { set interesting [lmap a [interp aliases ""] {expr {![string match ::p::* $a] ? $a : [continue]}}] + set interesting [lmap a $interesting {expr {![string match *twapi::* $a] ? $a : [continue]}}] + set interesting [lmap a $interesting {expr {![string match *vfs::* $a] ? $a : [continue]}}] set matched [lsearch -all -inline $interesting $glob] } - proc alias {a args} { + proc alias {{aliasorglob ""} args} { if {[llength $args]} { - if {$a in [interp aliases ""]} { - set existing [interp alias "" $a] - puts stderr "Overwriting existing alias $a -> $existing with $a -> $args (in current session only)" + if {$aliasorglob in [interp aliases ""]} { + set existing [interp alias "" $aliasorglob] + puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)" } - interp alias "" $a "" {*}$args + interp alias "" $aliasorglob "" {*}$args } else { - return [interp alias "" $a] + if {![string length $aliasorglob]} { + set aliaslist [punk aliases] + puts -nonewline stderr $aliaslist + return + } + if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { + set aliaslist [punk aliases $aliasorglob] + puts -nonewline stderr $aliaslist + return + } + return [interp alias "" $aliasorglob] } } + #know is critical to the punk repl for proper display output + interp alias {} know {} punk::know + interp alias {} know? {} punk::know? + + + interp alias {} ansi {} punk::ansi + interp alias {} a+ {} punk::ansi+ + #sh style 'test' and 'exitcode' (0 is false) interp alias {} sh_test {} punk::sh_test interp alias {} sh_echo {} punk::sh_echo @@ -494,13 +979,22 @@ namespace eval punk { interp alias {} echo {} punk::sh_echo interp alias {} ECHO {} punk::sh_ECHO - interp alias {} c {} clear + #interp alias {} c {} clear ;#external executable 'clear' may not always be available + interp alias {} clear {} repl::term::reset + interp alias {} c {} repl::term::reset interp alias {} help {} punk help interp alias {} aliases {} punk aliases interp alias {} alias {} punk alias interp alias {} treemore {} punk::xmore tree + + #---------------------------------------------- + interp alias {} linelistraw {} punk::linelistraw + interp alias {} linelist {} punk::linelist + interp alias {} linedict {} punk::linedict + interp alias {} dictline {} punk::dictline + #---------------------------------------------- #leave the winpath related aliases available on all platforms interp alias {} cdwin {} punk cdwin @@ -515,6 +1009,7 @@ namespace eval punk { interp alias {} gconf {} git config --global -l #---------------------------------------------- + # ls aliases - note that tcl doesn't exand * but sh_xxx functions pass to sh -c allowing shell expansion interp alias {} l {} sh_runout -n ls -A ;#plain text listing #interp alias {} ls {} sh_runout -n ls -AF --color=always @@ -533,12 +1028,28 @@ namespace eval punk { } else { #todo - natsorted equivalent #interp alias {} dl {} + interp alias {} dl {} puts stderr "not implemented" + interp alias {} dw {} puts stderr "not implemented" #todo - powershell detection on other platforms set has_powershell 0 } if {$has_powershell} { + interp alias {} ps {} exec >@stdout pwsh -nolo -nop -c + interp alias {} psx {} runx -n pwsh -nop -nolo -c + interp alias {} psr {} run -n pwsh -nop -nolo -c + interp alias {} psout {} runout -n pwsh -nop -nolo -c + interp alias {} pserr {} runerr -n pwsh -nop -nolo -c interp alias {} psls {} pwsh -nop -nolo -c ls interp alias {} psps {} pwsh -nop -nolo -c ps + } else { + set ps_missing "powershell missing (powershell is open source and can be installed on windows and most unix-like platforms)" + interp alias {} ps {} puts stderr $ps_missing + interp alias {} psx {} puts stderr $ps_missing + interp alias {} psr {} puts stderr $ps_missing + interp alias {} psout {} puts stderr $ps_missing + interp alias {} pserr {} puts stderr $ps_missing + interp alias {} psls {} puts stderr $ps_missing + interp alias {} psps {} puts stderr $ps_missing } } diff --git a/src/modules/shellfilter-0.1.8.tm b/src/modules/shellfilter-0.1.8.tm index b4d6a3fa..bb435ecd 100644 --- a/src/modules/shellfilter-0.1.8.tm +++ b/src/modules/shellfilter-0.1.8.tm @@ -125,11 +125,13 @@ namespace eval shellfilter::ansi { variable test "blah\033\[1;33mETC\033\[0;mOK" namespace export + variable map { - bold 1 light 2 blink 5 invert 7 + bold 1 light 2 blink 5 invert 7 underline 4 black 30 red 31 green 32 yellow 33 blue 34 purple 35 cyan 36 white 37 Black 40 Red 41 Green 42 Yellow 43 Blue 44 Purple 45 Cyan 46 White 47 } proc + {args} { + #don't disable ansi here. + #we want this to be available to call even if ansi is off variable map set t 0 foreach i $args { diff --git a/src/modules/shellrun-0.1.tm b/src/modules/shellrun-0.1.tm index 34cfff93..5a78b3fd 100644 --- a/src/modules/shellrun-0.1.tm +++ b/src/modules/shellrun-0.1.tm @@ -18,7 +18,6 @@ namespace eval shellrun { variable runout variable runerr - proc get_run_opts {arglist} { if {[catch { set callerinfo [info level -1] @@ -58,16 +57,29 @@ namespace eval shellrun { } else { set nonewline 0 } - - set id_err [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + set idlist_stderr [list] + #we leave stdout without imposed ansi colouring - because the source may be colourised + #stderr might have source colouring - but it usually doesn't seem to, and the visual distiction of red stderr is very handy for the run command. + #A further enhancement could be to detect well-known options such as --color and/or use a configuration for specific commands that have useful colourised stderr, + #but defaulting stderr to red is a pretty reasonable compromise. + #Note that the other run commands, runout,runerr, runx don't emit in real-time - so for those commands there may be options to detect and/or post-process stdout and stderr. + #TODO - fix. This has no effect because the repl adds an ansiwrap transform + # what we probably want to do is 'aside' that transform for runxxx commands only. + #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + + #--------------------------------------------------------------------------------------------- set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none ] - shellfilter::stack::remove stderr $id_err + #--------------------------------------------------------------------------------------------- + + foreach id $idlist_stderr { + shellfilter::stack::remove stderr $id + } flush stderr flush stdout - set c [shellfilter::ansi::+ green] - set n [shellfilter::ansi::+] + set c [a+ green] + set n [a+] if {[dict exists $exitinfo error]} { error "[dict get $exitinfo error]\n$exitinfo" } @@ -140,10 +152,13 @@ namespace eval shellrun { set c [a+ Yellow red bold] } #exitcode not part of return value for runout - colourcode appropriately - lappend chunklist [list stderr "$c$exitinfo$n\n"] + lappend chunklist [list "info" "$c$exitinfo$n"] - set chunk "[a+ red bold]stderr[a+]\n" + set chunk "[a+ red bold]stderr[a+]" + lappend chunklist [list "info" $chunk] + + set chunk "" if {[string length $::shellrun::runerr]} { if {$nonewline} { set e [string trimright $::shellrun::runerr \r\n] @@ -157,7 +172,7 @@ namespace eval shellrun { - lappend chunklist [list stderr "[a+ white bold]stdout[a+]\n"] + lappend chunklist [list "info" "[a+ white bold]stdout[a+]"] set chunk "" if {[string length $::shellrun::runout]} { if {$nonewline} { @@ -165,9 +180,9 @@ namespace eval shellrun { } else { set o $::shellrun::runout } - append chunk "$o\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. + append chunk "$o" ;#this newline is the display output separator - always there whether data has trailing newline or not. } - lappend chunklist [list stdout $chunk] + lappend chunklist [list result $chunk] set ::punk::last_run_display $chunklist @@ -235,10 +250,10 @@ namespace eval shellrun { set c [a+ Yellow red bold] } #exitcode not part of return value for runout - colourcode appropriately - lappend chunklist [list stderr "$c$exitinfo$n\n"] + lappend chunklist [list "info" "$c$exitinfo$n"] - lappend chunklist [list stderr "[a+ white bold]stdout[a+]\n"] + lappend chunklist [list "info" "[a+ white bold]stdout[a+]"] set chunk "" if {[string length $::shellrun::runout]} { if {$nonewline} { @@ -252,16 +267,19 @@ namespace eval shellrun { - set chunk "[a+ red bold]stderr[a+]\n" + set chunk "[a+ red bold]stderr[a+]" + lappend chunklist [list "info" $chunk] + + set chunk "" if {[string length $::shellrun::runerr]} { if {$nonewline} { set e [string trimright $::shellrun::runerr \r\n] } else { set e $::shellrun::runerr } - append chunk "$e\n" + append chunk "$e" } - lappend chunklist [list stderr $chunk] + lappend chunklist [list resulterr $chunk] set ::punk::last_run_display $chunklist @@ -325,7 +343,7 @@ namespace eval shellrun { #set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] set chunklist [list] - lappend chunklist [list stderr "[a+ white bold]stdout[a+]\n"] + lappend chunklist [list "info" "[a+ white bold]stdout[a+]"] set chunk "" if {[string length $::shellrun::runout]} { @@ -334,21 +352,25 @@ namespace eval shellrun { } else { set o $::shellrun::runout } - append chunk $o\n + append chunk $o } - lappend chunklist [list stdout $chunk] + lappend chunklist [list result $chunk] + + set chunk "[a+ red bold]stderr[a+]" + lappend chunklist [list "info" $chunk] - set chunk "[a+ red bold]stderr[a+]\n" + set chunk "" if {[string length $::shellrun::runerr]} { if {$nonewline} { set e [string trimright $::shellrun::runerr \r\n] } else { set e $::shellrun::runerr } - append chunk $e\n + append chunk $e } - lappend chunklist [list stderr $chunk] + #stderr is part of the result + lappend chunklist [list "resulterr" $chunk] @@ -362,7 +384,7 @@ namespace eval shellrun { set c [a+ white bold] } } - lappend chunklist [list stderr "$c$exitinfo$n\n"] + lappend chunklist [list result "$c$exitinfo$n"] set ::punk::last_run_display $chunklist @@ -371,12 +393,107 @@ namespace eval shellrun { if {$nonewline} { - return [list stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n] {*}$exitinfo] + return [list {*}$exitinfo stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n]] } #always return exitinfo $code at beginning of dict (so that punk unknown can interpret the exit code as a unix-style bool if double evaluated) return [list {*}$exitinfo stdout $::shellrun::runout stderr $::shellrun::runerr] } + #an experiment + # + #run as raw string instead of tcl-list - no variable subst etc + # + #dummy repl_runraw that repl will intercept + proc repl_runraw {args} { + error "runraw: only available in repl as direct call - not from script" + } + #we can only call runraw with a single (presumably braced) string if we want to use it from both repl and tcl scripts + proc runraw {commandline} { + set ::punk::last_run_display [list] + variable last_run_display + variable runout + variable runerr + set runout "" + set runerr "" + + #return [shellfilter::run [lrange $args 1 end] -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] + puts stdout ">>runraw got: $commandline" + + #run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing + #for consistency with other runxxx commands - we'll just consume it. (review) + #set wordparts [regexp -inline -all {\S+} $commandline] + package require string::token::shell + set parts [string token shell -indices $commandline] + puts stdout ">>shellparts: $parts" + + set runwords [list] + foreach p $parts { + set ptype [lindex $p 0] + set pval [lindex $p 3] + if {$ptype eq "PLAIN"} { + lappend runwords [lindex $p 3] + } elseif {$ptype eq "D:QUOTED"} { + set v {"} + append v $pval + append v {"} + lappend runwords $v + } elseif {$ptype eq "S:QUOTED"} { + set v {'} + append v $pval + append v {'} + lappend runwords $v + } + } + puts stdout ">>runraw runwords: $runwords" + set runwords [lrange $runwords 1 end] + + puts stdout ">>runraw runwords: $runwords" + #set args [lrange $args 1 end] + #set runwords [lrange $wordparts 1 end] + + set known_runopts [list "-echo" "-e" "-terminal" "-t"] + set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self + set runopts [list] + set cmdwords [list] + set idx_first_cmdarg [lsearch -not $runwords "-*"] + set runopts [lrange $runwords 0 $idx_first_cmdarg-1] + set cmdwords [lrange $runwords $idx_first_cmdarg end] + + foreach o $runopts { + if {$o ni $known_runopts} { + error "runraw: Unknown runoption $o" + } + } + set runopts [lmap o $runopts {dict get $aliases $o}] + + set cmd_as_string [join $cmdwords " "] + puts stdout ">>cmd_as_string: $cmd_as_string" + + if {"-terminal" in $runopts} { + #fake terminal using 'script' command. + #not ideal: smushes stdout & stderr together amongst other problems + set tcmd [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdwords] + puts stdout ">>tcmd: $tcmd" + set exitinfo [shellfilter::run $tcmd -teehandle punk -inbuffering line -outbuffering none ] + set exitinfo "exitcode not-implemented" + } else { + set exitinfo [shellfilter::run $cmdwords -teehandle punk -inbuffering line -outbuffering none ] + } + + if {[dict exists $exitinfo error]} { + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + puts stderr $c + return $exitinfo + } + proc sh_run {args} { set splitargs [get_run_opts $args] set runopts [dict get $splitargs runopts] @@ -406,7 +523,6 @@ namespace eval shellrun { } namespace eval shellrun { - interp alias {} a+ {} shellfilter::ansi::+ interp alias {} run {} shellrun::run interp alias {} sh_run {} shellrun::sh_run @@ -417,5 +533,12 @@ namespace eval shellrun { interp alias {} runx {} shellrun::runx interp alias {} sh_runx {} shellrun::sh_runx + #the shortened versions deliberately don't get pretty output from the repl + interp alias {} r {} shellrun::run + interp alias {} ro {} shellrun::runout + interp alias {} re {} shellrun::runerr + interp alias {} rx {} shellrun::runx + + } diff --git a/src/punk86.vfs/lib/app-punk/repl.tcl b/src/punk86.vfs/lib/app-punk/repl.tcl index bc019397..fea741a5 100644 --- a/src/punk86.vfs/lib/app-punk/repl.tcl +++ b/src/punk86.vfs/lib/app-punk/repl.tcl @@ -23,27 +23,99 @@ set tcl_interactive 1 proc todo {} { puts "tcl History" - } + + tcl::tm::add [pwd]/modules if {![info exists ::env(SHELL)]} { set ::env(SHELL) punk86 } if {![info exists ::env(TERM)]} { - #fake it - #set ::env(TERM) vt100 - set ::env(TERM) xterm-256color + # tset -r seems to rely on env(TERM) - so this doesn't seem to work + #if {![catch {exec tset -r} result]} { + # #e.g Terminal type is xterm-256color. + # set t [string trimright [lindex $result end] .] + # set ::env(TERM) $t + #} else { + #fake it ? + #set ::env(TERM) vt100 + set ::env(TERM) xterm-256color + #} } - +#These are strong dependencies +# - the repl requires Threading and punk,shellfilter,shellrun to call and display properly. package require shellfilter package require shellrun package require Thread package require punk +#todo - move to less generic namespace +namespace eval repl { + variable screen_last_chars "" ;#a small sliding append buffer for last char of any screen output to detect \n vs string + variable screen_last_char_list [list] + + variable last_unknown "" + variable prompt_reset_flag 0 ;#trigger repl to re-retrieve prompt settings + variable output "" + #important not to initialize - as it can be preset by cooperating package before app-punk has been package required + variable post_script + variable signal_control_c 0 +} + +namespace eval punkrepl { + variable debug_repl 0 +} + + +namespace eval ::repl::term { +} + +package require term::ansi::code::ctrl +if {$::tcl_platform(platform) eq "windows"} { + package require twapi + proc ::repl::term::handler_console_control {args} { + set ::repl::signal_control_c 1 + #rputs stderr "* console_control: $args" + #return 0 to fall through to default handler + return 1 + } + twapi::set_console_control_handler ::repl::term::handler_console_control + proc ::repl::term::set_console_title {text} { + #twapi::set_console_title $text + puts -nonewline [term::ansi::code::ctrl::title $text] + } + proc ::repl::term::set_console_icon {name} { + #todo + } +} else { + #TODO + proc ::repl::term::set_console_title {text} { + #todo - terminfo/termcap? + #puts -nonewline "\033\]2;$text\007" ;#works for xterm and most derivatives + puts -nonewline [term::ansi::code::ctrl::title $text] + } + proc ::repl::term::set_console_icon {name} { + #old xterm feature for label given to xterm window when miniaturized? TODO research + #puts -nonewline "\033\]1;$name\007" + } +} + + +#expermental terminal alt screens +proc ::repl::term::screen_push_alt {} { + #tput smcup + puts -nonewline stderr "\033\[?1049h" +} +proc ::repl::term::screen_pop_alt {} { + #tput rmcup + puts -nonewline stderr "\033\[?1049l" +} +interp alias {} smcup {} ::repl::term::screen_push_alt +interp alias {} rmcup {} ::repl::term::screen_pop_alt @@ -77,7 +149,8 @@ set err [dict get $errdevice localchan] # args - A list whose elements are the words of the original # command, including the command name. -proc unknown args { +proc ::unknown args { + variable ::tcl::UnknownPending global auto_noexec auto_noload env tcl_interactive errorInfo errorCode @@ -305,9 +378,12 @@ proc unknown args { set ::tcl::UnknownResult "" } } else { - + set idlist_stdout [list] + set idlist_stderr [list] + set shellrun::runout "" #when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks - set id_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + #lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] if {![dict get $::punk::config::running exec_unknown]} { uplevel 1 [list ::catch \ @@ -323,16 +399,34 @@ proc unknown args { set ::tcl::UnknownResult "" } } else { + set ::punk::last_run_display [list] + set redir ">&@stdout <@stdin" uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] #we can't detect stdout/stderr output from the exec #for now emit an extra \n on stderr #todo - use console apis (twapi on windows) to detect cursor posn? - puts -nonewline stderr \n[a+ green bold]-[a+] - } + # + # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit + if {[dict get $::tcl::UnknownOptions -code] == 0} { + set c green + set m "ok" + } else { + set c yellow + set m "errorCode $::errorCode" + } + set chunklist [list] + lappend chunklist [list "info" "[a+ $c]$m[a+] " ] + set ::punk::last_run_display $chunklist + } - shellfilter::stack::remove stderr $id_stderr + foreach id $idlist_stdout { + shellfilter::stack::remove stdout $id + } + foreach id $idlist_stderr { + shellfilter::stack::remove stderr $id + } } @@ -362,174 +456,93 @@ proc unknown args { return -options $::tcl::UnknownOptions $::tcl::UnknownResult } - set ret [catch {set candidates [info commands $name*]} msg] - if {$name eq "::"} { - set name "" - } - if {$ret != 0} { - dict append opts -errorinfo \ - "\n (expanding command prefix \"$name\" in unknown)" - return -options $opts $msg - } - # Filter out bogus matches when $name contained - # a glob-special char [Bug 946952] - if {$name eq ""} { - # Handle empty $name separately due to strangeness - # in [string first] (See RFE 1243354) - set cmds $candidates - } else { - set cmds [list] - foreach x $candidates { - if {[string first $name $x] == 0} { - lappend cmds $x - } - } - } - if {[llength $cmds] == 1} { - uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ - ::tcl::UnknownResult ::tcl::UnknownOptions] - dict incr ::tcl::UnknownOptions -level - return -options $::tcl::UnknownOptions $::tcl::UnknownResult - } - if {[llength $cmds]} { - return -code error "ambiguous command name \"$name\": [lsort $cmds]" - } + set ret [catch {set candidates [info commands $name*]} msg] + if {$name eq "::"} { + set name "" } - return -code error -errorcode [list TCL LOOKUP COMMAND $name] \ - "invalid command name \"$name\"" -} - - -proc know {cond body} { - proc unknown {args} [string map [list @c@ $cond @b@ $body] { - if {![catch {expr {@c@}} res] && $res} { - return [eval {@b@}] - #tailcall @b@ - } - }][info body unknown] -} -proc know? {} { - puts [string range [info body unknown] 0 511] -} -if 1 { -know {[expr $args] || 1} {expr $args} -know {[regexp {^([0-9]+)\.\.([0-9]+)$} [lindex $args 0] -> from to]} { - set res {} - while {$from<=$to} {lappend res $from; incr from} - set res -} - -#handle process return dict of form {exitcode num etc blah} -#ie when the return result as a whole is treated as a command -#exitcode must be the first key -know {[lindex $args 0 0] eq "exitcode"} { - #set c [lindex $args 0 1] - uplevel 1 [list exitcode {*}[lrange [lindex $args 0] 1 end]] -} - - -#run as raw string instead of tcl-list - no variable subst etc -proc do_runraw {commandline} { - #return [shellfilter::run [lrange $args 1 end] -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] - puts stdout ">>runraw got: $commandline" - - #run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing - #for consistency with other runxxx commands - we'll just consume it. (review) - #set wordparts [regexp -inline -all {\S+} $commandline] - package require string::token::shell - set parts [string token shell -indices $commandline] - puts stdout ">>shellparts: $parts" - - set runwords [list] - foreach p $parts { - set ptype [lindex $p 0] - set pval [lindex $p 3] - if {$ptype eq "PLAIN"} { - lappend runwords [lindex $p 3] - } elseif {$ptype eq "D:QUOTED"} { - set v {"} - append v $pval - append v {"} - lappend runwords $v - } elseif {$ptype eq "S:QUOTED"} { - set v {'} - append v $pval - append v {'} - lappend runwords $v - } + if {$ret != 0} { + dict append opts -errorinfo \ + "\n (expanding command prefix \"$name\" in unknown)" + return -options $opts $msg } - puts stdout ">>runraw runwords: $runwords" - set runwords [lrange $runwords 1 end] - - puts stdout ">>runraw runwords: $runwords" - #set args [lrange $args 1 end] - #set runwords [lrange $wordparts 1 end] - - set known_runopts [list "-echo" "-e" "-terminal" "-t"] - set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self - set runopts [list] - set cmdwords [list] - set idx_first_cmdarg [lsearch -not $runwords "-*"] - set runopts [lrange $runwords 0 $idx_first_cmdarg-1] - set cmdwords [lrange $runwords $idx_first_cmdarg end] - - foreach o $runopts { - if {$o ni $known_runopts} { - error "runraw: Unknown runoption $o" + # Filter out bogus matches when $name contained + # a glob-special char [Bug 946952] + if {$name eq ""} { + # Handle empty $name separately due to strangeness + # in [string first] (See RFE 1243354) + set cmds $candidates + } else { + set cmds [list] + foreach x $candidates { + if {[string first $name $x] == 0} { + lappend cmds $x + } } } - set runopts [lmap o $runopts {dict get $aliases $o}] - - set cmd_as_string [join $cmdwords " "] - puts stdout ">>cmd_as_string: $cmd_as_string" - - if {"-terminal" in $runopts} { - set tcmd [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdwords] - puts stdout ">>tcmd: $tcmd" - #set exitinfo [shellfilter::run $tcmd -teehandle punk -inbuffering line -outbuffering none ] - set exitinfo "exitcode not-implemented" + #punk - disable prefix match search + set default_cmd_search 0 + if {$default_cmd_search} { + if {[llength $cmds] == 1} { + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + if {[llength $cmds]} { + return -code error "ambiguous command name \"$name\": [lsort $cmds]" + } } else { - set exitinfo [shellfilter::run $cmdwords -teehandle punk -inbuffering line -outbuffering none ] + #punk hacked version - report matches but don't run + if {[llength $cmds]} { + return -code error "unknown command name \"$name\": possible match(es) [lsort $cmds]" + } + } - if {[dict exists $exitinfo error]} { - #todo - check errorInfo makes sense.. return -code? tailcall? - error [dict get $exitinfo error] - } - set code [dict get $exitinfo exitcode] - if {$code == 0} { - set c [shellfilter::ansi::+ green] - } else { - set c [shellfilter::ansi::+ white bold] + } - puts stderr $c - return $exitinfo + return -code error -errorcode [list TCL LOOKUP COMMAND $name] \ + "invalid command name \"$name\"" } +punk::configure_unknown ;#must be called because we hacked the tcl 'unknown' proc -know {[lindex $args 0] eq "runraw"} { - return [do_runraw $args] -} -} -namespace eval repl { - variable output "" - #important not to initialize - as it can be preset by cooperating package before app-punk has been package required - variable post_script + +proc repl::reset_prompt {} { + variable prompt_reset_flag + set prompt_reset_flag 1 } +#todo - review +proc repl::term::reset {} { + set prompt_reset_flag 1 + #clear ;#call to external executable which may not be available + puts stdout [::term::ansi::code::ctrl::rd] +} proc repl::doprompt {prompt {col {green bold}}} { #prompt to stderr. #We can pipe commands into repl's stdin without the prompt interfering with the output. #Although all command output for each line goes to stdout - not just what is emmited with puts if {$::tcl_interactive} { - set o [shellfilter::ansi::+ {*}$col] - set r [shellfilter::ansi::+] + set o [a+ {*}$col] + set r [a+] puts -nonewline stderr $o$prompt$r flush stderr } } - +proc repl::get_prompt_config {} { + if {$::tcl_interactive} { + set resultprompt "[a+ green bold]-[a+] " + set infoprompt "[a+ green bold]*[a+] " + set debugprompt "[a+ purple bold]~[a+] " + } else { + set resultprompt "" + set infoprompt "" + set debugprompt "" + } + return [list resultprompt $resultprompt infoprompt $infoprompt debugprompt $debugprompt] +} proc repl::start {inchan} { variable command variable running @@ -537,8 +550,9 @@ proc repl::start {inchan} { variable done set running 1 set command "" + set prompt_config [get_prompt_config] doprompt "P% " - fileevent $inchan readable [list [namespace current]::repl_handler $inchan] + fileevent $inchan readable [list [namespace current]::repl_handler $inchan $prompt_config] set reading 1 vwait [namespace current]::done #todo - override exit? @@ -553,10 +567,7 @@ proc repl::post_operations {} { set ::repl::post_script "" uplevel #0 {eval $::repl::running_script} } - #todo - tidyup so repl could be restarted - - set repl::post_operations_done 0 } @@ -645,7 +656,167 @@ proc repl::reopen_stdinX {} { after 10 repl::start $a } -proc repl::repl_handler {chan} { + +#add to sliding buffer of last x chars emmitted to screen by repl +#(we could maintain only one char - more kept merely for debug assistance) +#will not detect emissions from exec with stdout redirected and presumably some extensions etc +proc repl::screen_last_char_add {c what {why ""}} { + variable screen_last_chars + variable screen_last_char_list + if {![string length $c]} { + return [string index $screen_last_chars end] + } + if {[string length $screen_last_chars] > 10} { + set screen_last_chars [string range $screen_last_chars 1 end] ;#evict first char + set screen_last_char_list [lrange $screen_last_char_list 1 end] + } + append screen_last_chars $c + lappend screen_last_char_list [list $c $what $why] + #return [string index $screen_last_chars end] + return [lindex $screen_last_char_list 0 0] +} +proc repl::screen_last_char_get {} { + variable screen_last_char_list + return [lindex $screen_last_char_list end 0] +} +proc repl::screen_last_char_getinfo {} { + variable screen_last_char_list + return [lindex $screen_last_char_list end] +} + +#-------------------------------------- +#another experiment +proc repl::newout {} { + namespace eval ::replout { + namespace ensemble create -map { + initialize init + finalize close + watch watch + write write + } + } + proc ::replout::init {id mode} { + return {initialize finalize watch write} + } + proc ::replout::close {id} { + + } + proc ::replout::watch {id spec} { + + } + proc ::replout::write {id data} { + puts -nonewline stderr $data + return [string length $data] + } + + close stdout + set fd [chan create write ::replout] + chan configure $fd -buffering none + return $fd +} +interp alias {} newout {} repl::newout +proc repl::newout2 {} { + close stdout + set s [open "CON" w] + chan configure $s -buffering none +} +#-------------------------------------- + +#use rputs in repl_handler instead of puts +# - to help ensure we don't emit extra blank lines in info or debug output +#rputs expects the standard tcl 'puts' command to be in place. +# all bets are off if this has been redefined with some other api +# rputs deliberately doesn't check screen_last_chars before emitting data (unless reporting an error in rputs itself) +proc repl::rputs {args} { + variable screen_last_chars + + variable last_out_was_newline + variable last_repl_char + + if {[::tcl::mathop::<= 1 [llength $args] 3]} { + set out [lindex $args end] + if {([llength $args] > 1) && [lindex $args 0] ne "-nonewline"} { + set this_tail \n + set rputschan [lindex $args 0] + } elseif {[llength $args] == 1} { + set this_tail \n + set rputschan "stdout" + } else { + #>1 arg with -nonewline + set this_tail [string index $out end] + set rputschan [lindex $args 1] + } + set last_char_info_width 40 + set summary "[::shellfilter::ansi::stripcodes [string range $out 0 $last_char_info_width]]" + if {[string length $out] > $last_char_info_width} { + append summary " ..." + } + screen_last_char_add $this_tail repl-$rputschan" $summary + #tailcall? + puts {*}$args + } else { + #looks like an invalid puts call - use the normal error produced by the puts command + #This should only occur if the repl itself is being rewritten/debugged, + #so we will use red "!" and not worry about the extra newlines before and after + if {[catch { puts {*}$args } err]} { + set c [a+ yellow bold] + set n [a+] + #possibly non punk-compliant output because we're assuming the repl was the most recent emitter + #could be wrong, in which case we may emit an extra newline + #- shouldn't matter in this case + #set last_char [string range $screen_last_chars end] + set last_char [screen_last_char_get] + if {$last_char eq "\n"} { + set clear "" + } else { + set clear "\n" + } + puts -nonewline stderr "$clear[a+ red bold]! REPL ERROR IN rputs $c$err$n\n" + screen_last_char_add "\n" replerror "rputs err: '$err'" + return + } else { + #?? shouldn't happen with standard puts command + #do our best and assume final arg is still the data being emitted + #worst that will happen is we won't detect a trailing newline and will later emit an extra blank line. + set out [lindex $args end] + set this_tail [string index $out end] + screen_last_char_add $this_tail replunknown "rputs $args" + return + } + } +} +#whether we need a newline as clearance from previous output +proc repl::screen_needs_clearance {} { + variable screen_last_chars + + #set last_char [string index $screen_last_chars end] + set last_char_info [screen_last_char_getinfo] + if {![llength $last_char_info]} { + #assumption + return 1 + } + lassign $last_char_info c what why + if {$what in [list "stdout" "stderr" "stdout/stderr"]} { + return 1 + } + + + if {$c eq "\n"} { + return 0 + } else { + return 1 + } +} + +proc repl::repl_handler {inputchan prompt_config} { + variable prompt_reset_flag + if {$prompt_reset_flag == 1} { + set prompt_config [get_prompt_config] + set prompt_reset_flag 0 + } + variable last_repl_char "" ;#last char emitted by this handler to stdout/stderr + variable lastoutchar "" + variable lasterrchar "" variable command variable running variable reading @@ -653,14 +824,14 @@ proc repl::repl_handler {chan} { variable id_outstack upvar ::punk::last_run_display last_run_display upvar ::punk::config::running running_config - set chunksize [gets $chan line] + set chunksize [gets $inputchan line] if {$chunksize < 0} { - if {[chan eof $chan]} { - fileevent $chan readable {} + if {[chan eof $inputchan]} { + fileevent $inputchan readable {} set reading 0 set running 0 if {$::tcl_interactive} { - puts stderr "\n|repl> EOF on $chan." + rputs stderr "\n|repl> EOF on $inputchan." } set [namespace current]::done 1 #test @@ -668,47 +839,153 @@ proc repl::repl_handler {chan} { return } } - append command $line + set resultprompt [dict get $prompt_config resultprompt] + set infoprompt [dict get $prompt_config infoprompt] + set debugprompt [dict get $prompt_config debugprompt] + + + append command $line\n + set ::repl::last_repl_char "\n" ;#this is actually the eol from stdin + screen_last_char_add "\n" stdin $line if {[info complete $command]} { set ::repl::output_stdout "" set ::repl::output_stderr "" set outstack [list] set errstack [list] - if {[string length [dict get $running_config color_stdout]]} { + + + #oneshot repl debug + set wordparts [regexp -inline -all {\S+} $command] + lassign $wordparts cmd_firstword cmd_secondword + if {$cmd_firstword eq "debugrepl"} { + if {[string is integer -strict $cmd_secondword]} { + incr ::punkrepl::debug_repl $cmd_secondword + } else { + incr ::punkrepl::debug_repl + } + set command "set ::punkrepl::debug_repl" + } + if {$::punkrepl::debug_repl > 0} { + proc debug_repl_emit {msg} [string map [list %p% [list $debugprompt]] { + set p %p% + #don't auto-append \n even if missing. + #we may want to use debug_repl_emit with multiple calls for one output line + #if {[string index $msg end] ne "\n"} { + # set msg "$msg\n" + #} + #set last_char [string index $::repl::screen_last_chars end] + set last_char [screen_last_char_get] + if {$last_char ne "\n"} { + set clearance "\n" + } else { + set clearance "" + } + rputs stderr $clearance$p[string map [list \n \n$p] $msg] + }] + set info "last_run_info\n" + append info "length: [llength $::punk::last_run_display]\n" + debug_repl_emit $info + } else { + proc debug_repl_emit {msg} {return} + } + + + + set ::punk::last_run_display [list] + set ::repl::last_unknown "" + #*********************************************************** + #don't use puts,rputs or debug_repl_emit in this block + #*********************************************************** + if {[string length [dict get $running_config color_stdout]] && [punk::ansi]} { lappend outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]] } lappend outstack [shellfilter::stack::add stdout tee_to_var -settings {-varname ::repl::output_stdout}] - if {[string length [dict get $running_config color_stderr]]} { + if {[string length [dict get $running_config color_stderr]] && [punk::ansi]} { lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]] } - lappend errstack [shellfilter::stack::add stderr tee_to_var -settings {-varname ::repl::output_stderr}] #chan configure stdout -buffering none - fileevent $chan readable {} + fileevent $inputchan readable {} set reading 0 #don't let unknown use 'args' to convert command to list - - if {[string equal -length [string length "runraw "] "runraw " $command]} { - set status [catch {uplevel #0 [list do_runraw $command]} result] + #=============================================================================== + #Actual command call + #=============================================================================== + if {[string equal -length [string length "repl_runraw "] "repl_runraw " $command]} { + #pass unevaluated command to runraw + set status [catch {uplevel #0 [list runraw $command]} result] } else { #puts stderr "repl uplevel 0 '$command'" set status [catch {uplevel #0 $command} result] } - + #=============================================================================== flush stdout flush stderr - foreach s [lreverse $outstack] { shellfilter::stack::remove stdout $s } foreach s [lreverse $errstack] { shellfilter::stack::remove stderr $s } - set lastoutchar [string range $::repl::output_stdout end-1 end] - set lasterrchar [string range $::repl::output_stderr end-1 end] - set ::repl::last_stdout $::repl::output_stdout - set ::repl::last_stderr $::repl::output_stderr + + set lastoutchar [string index $::repl::output_stdout end] + set lasterrchar [string index $::repl::output_stderr end] + + #to determine whether cursor is back at col0 of newline + screen_last_char_add [string index $lastoutchar$lasterrchar end] "stdout/stderr" + + set result_is_chunk_list 0 + #------ + #todo - fix. It doesn't make much sense to only detect if the unknown command occurred in first word. + #e.g set x [something arg] not detected vs something arg + #also - unknown commands aren't the only things that can write directly to the os handles stderr & stdout + if { + [string length $::repl::last_unknown] && \ + [string equal -length [string length $::repl::last_unknown] $::repl::last_unknown $command] + } { + #can't currently detect stdout/stderr writes from unknown's call to exec + #add a clearance newline for direct unknown calls for now + #there is usually output anyway - but we will get an extra blank line now even for a call that only had an exit code + # + # + set unknown_clearance "\n* repl newline" + screen_last_char_add "\uFFFF" clearance "clearance after direct unknown call" + if {[llength $last_run_display]} { + if {$status == 0} { + set result $last_run_display + } else { + + } + set result_is_chunk_list 1 + } + } + #------ + #ok to use repl::screen_needs_clearance from here down.. (code smell proc only valid use in narrow context) + #*********************************************************** + #rputs -nonewline stderr $unknown_clearance + set lastcharinfo "\n" + set whatcol [string repeat " " 12] + foreach cinfo $::repl::screen_last_char_list { + lassign $cinfo c whatinfo whyinfo + set cdisplay [string map [list \r "-r-" \n "-n-"] $c] + if {[string length $cdisplay] == 1} { + set cdisplay "$cdisplay " ;#make 3 wide to match -n- and -r- + } + set whatinfo [string range $whatinfo$whatcol 0 [string length $whatcol]] + set whysummary [string map [list \n "-n-"] $whyinfo] + append lastcharinfo "$cdisplay $whatinfo $whysummary\n" + } + debug_repl_emit "screen_last_chars: $lastcharinfo" + debug_repl_emit "lastoutchar:'$lastoutchar' lasterrchar: '$lasterrchar'" + if {$status == 0} { + debug_repl_emit "command call status: $status OK" + } else { + debug_repl_emit "command call status: $status ERR" + } + + + #puts stderr "'$::repl::output_stdout' lastoutchar:'$lastoutchar' result:'$result'" #$command is an unevaluated script at this point @@ -716,13 +993,11 @@ proc repl::repl_handler {chan} { #- lindex will fail #if {[lindex $command 0] eq "runx"} {} - set result_is_chunk_list 0 - set test [string trim $command] - if { + if { [string equal -length [string length "./ "] "./ " $command] || \ - [string equal "./" $command] || \ + [string equal "./\n" $command] || \ [string equal -length [string length "../ "] "../ " $command] || \ - [string equal "../" $command] || \ + [string equal "../\n" $command] || \ [string equal -length [string length "runx "] "runx " $command] || \ [string equal -length [string length "sh_runx "] "sh_runx " $command] || \ [string equal -length [string length "runout "] "runout " $command] || \ @@ -736,45 +1011,92 @@ proc repl::repl_handler {chan} { set result_is_chunk_list 1 } } - fileevent $chan readable [list [namespace current]::repl_handler $chan] + + + + + set reading 1 if {$result ne ""} { if {$status == 0} { - if {[string length $lastoutchar$lasterrchar]} { - puts -nonewline stderr \n + if {[screen_needs_clearance]} { + rputs -nonewline stderr \n } if {$result_is_chunk_list} { foreach c $result { - lassign $c chan text + lassign $c termchan text if {[string length $text]} { - puts -nonewline $chan $text + if {$termchan eq "result"} { + rputs stdout $resultprompt[string map [list \n "\n$resultprompt"] $text] + #puts -nonewline stdout $text + } elseif {$termchan eq "resulterr"} { + rputs stderr $resultprompt[string map [list \n "\n$resultprompt"] $text] + } elseif {$termchan eq "info"} { + rputs stderr $infoprompt[string map [list \n "\n$infoprompt"] $text] + } else { + rputs -nonewline $termchan $text + } } } } else { - puts $result + rputs $resultprompt[string map [list \n "\n$resultprompt"] $result] } doprompt "P% " } else { #tcl err - set c [shellfilter::ansi::+ yellow bold] - set n [shellfilter::ansi::+] - puts stderr $c$result$n + if {$result_is_chunk_list} { + foreach c $last_run_display { + lassign $c termchan text + if {[string length $text]} { + if {$termchan eq "result"} { + rputs stdout $resultprompt[string map [list \n "\n$resultprompt"] $text] + #puts -nonewline stdout $text + } elseif {$termchan eq "resulterr"} { + rputs stderr $resultprompt[string map [list \n "\n$resultprompt"] $text] + } elseif {$termchan eq "info"} { + rputs stderr $infoprompt[string map [list \n "\n$infoprompt"] $text] + } else { + rputs -nonewline $termchan $text + } + } + } + } + + set c [a+ yellow bold] + set n [a+] + rputs stderr $c$result$n #tcl err hint prompt - lowercase doprompt "p% " } } else { - if {[string length $lastoutchar$lasterrchar]} { + if {[screen_needs_clearance]} { doprompt "\nP% " } else { doprompt "P% " } } set command "" + if {$::punkrepl::debug_repl > 0} { + incr ::punkrepl::debug_repl -1 + } } else { - append command \n - doprompt "> " + #append command \n + if {$::repl::signal_control_c} { + set ::repl::signal_control_c 0 + rputs stderr "* console_control: control-c" + set c [a+ yellow bold] + set n [a+] + rputs stderr "${c}repl interrupted$n" + #set command [list error "repl interrupted"] + set command "" + doprompt ">_" + + } else { + doprompt "> " + } } + fileevent $inputchan readable [list [namespace current]::repl_handler $inputchan $prompt_config] } repl::start stdin diff --git a/src/punk86.vfs/lib/app-shellspy/shellspy.tcl b/src/punk86.vfs/lib/app-shellspy/shellspy.tcl index b44fe1be..94f5a20e 100644 --- a/src/punk86.vfs/lib/app-shellspy/shellspy.tcl +++ b/src/punk86.vfs/lib/app-shellspy/shellspy.tcl @@ -64,6 +64,7 @@ if {[file extension $arg1] in [list .tCl]} { package require flagfilter package require shellfilter package require Thread +package require punk #package require packageTrace