You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2607 lines
112 KiB
2607 lines
112 KiB
|
|
#punk linerepl |
|
#todo - make repls configurable/pluggable packages |
|
|
|
|
|
#list/string-rep bug |
|
global run_commandstr "" |
|
|
|
set stdin_info [chan configure stdin] |
|
if {[dict exists $stdin_info -inputmode]} { |
|
#this is the only way I currently know to detect console on windows.. doesn't work on Alma linux. |
|
# tcl_interactive used by repl to determine if stderr output prompt to be printed. |
|
# (that way, piping commands into stdin should not produce prompts for each command) |
|
set tcl_interactive 1 |
|
} |
|
#however, the -mode option only seems to appear on linux when a terminal exists.. |
|
if {[dict exists $stdin_info -mode]} { |
|
set tcl_interactive 1 |
|
} |
|
#give up for now |
|
set tcl_interactive 1 |
|
|
|
|
|
|
|
|
|
proc todo {} { |
|
puts "tcl History" |
|
puts "repltelemetry package" |
|
puts "deaddrop package for a consistent way for modules to leave small notes to others that may come later." |
|
} |
|
|
|
|
|
|
|
package require Thread |
|
package require shellfilter |
|
package require shellrun |
|
package require punk |
|
package require punk::ns |
|
package require punk::ansi |
|
package require punk::console |
|
package require textblock |
|
|
|
|
|
|
|
|
|
if {![info exists ::env(SHELL)]} { |
|
set ::env(SHELL) punk86 |
|
} |
|
if {![info exists ::env(TERM)]} { |
|
# 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 |
|
#} |
|
} |
|
|
|
#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 |
|
#(this is an example of a deaddrop) |
|
variable post_script |
|
variable signal_control_c 0 |
|
} |
|
|
|
namespace eval punk::repl { |
|
variable debug_repl 0 |
|
|
|
proc has_script_var_bug {} { |
|
set script {set j [list spud] ; list} |
|
append script \n |
|
uplevel #0 $script |
|
set rep1 [tcl::unsupported::representation $::j] |
|
set script "" |
|
set rep2 [tcl::unsupported::representation $::j] |
|
|
|
set nostring1 [string match "*no string" $rep1] |
|
set nostring2 [string match "*no string" $rep2] |
|
|
|
#we assume it should have no string rep in either case |
|
#Review: check Tcl versions for behaviour/consistency |
|
if {!$nostring2} { |
|
return true |
|
} else { |
|
return false |
|
} |
|
} |
|
|
|
} |
|
namespace eval repl { |
|
#since we are targeting Tcl 8.6+ - we should be using 'interp bgerror .' |
|
#todo - make optional/configurable? |
|
proc bgerror2 {args} { |
|
puts stderr "====================" |
|
puts stderr "repl::bgerror" |
|
puts stderr "====================" |
|
puts stderr "[lindex $args 0]" |
|
puts stderr "-------------------" |
|
puts stderr "[lrange $args 1 end]" |
|
puts stderr "====================" |
|
puts stderr "^^^^^^^^^^^^^^^^^^^" |
|
} |
|
proc bgerror {message} { |
|
puts stderr "*> repl background error: $message" |
|
puts stderr "*> [set ::errorInfo]" |
|
set stdinreader [fileevent stdin readable] |
|
if {![string length $stdinreader]} { |
|
puts stderr "*> stdin reader inactive" |
|
} else { |
|
puts stderr "*> stdin reader active" |
|
} |
|
} |
|
|
|
if {![llength [info commands ::bgerror]]} { |
|
interp alias {} bgerror {} ::repl::bgerror |
|
} |
|
} |
|
|
|
namespace eval ::repl::term { |
|
} |
|
|
|
package require term::ansi::code::ctrl |
|
|
|
|
|
if {$::tcl_platform(platform) eq "windows"} { |
|
#jmn disable twapi |
|
#package require zzzload |
|
#zzzload::pkg_require twapi |
|
after idle [list after 1000 { |
|
#puts stdout "===============repl loading twapi===========" |
|
#zzzload::pkg_wait twapi |
|
|
|
if {![catch {package require twapi}]} { |
|
|
|
proc ::repl::term::handler_console_control {args} { |
|
#puts -nonewline stdout . |
|
#flush stdout |
|
incr ::repl::signal_control_c |
|
#rputs stderr "* console_control: $args" |
|
if {$::punk::console::is_raw} { |
|
#how to let rawmode loop handle it? It doesn't seem to get through if we return 0 |
|
puts stderr "signal ctrl-c while in raw mode" |
|
after 200 {exit 42} ;#temp |
|
|
|
flush stderr |
|
return 42 |
|
} |
|
#note - returning 0 means pass event to other handlers including OS default handler |
|
if {$::repl::signal_control_c <= 2} { |
|
set remaining [expr {3 - $::repl::signal_control_c}] |
|
puts stderr "signal ctrl-c (perform $remaining more to quit, enter to return to repl)" |
|
flush stderr |
|
return 1 |
|
} elseif {$::repl::signal_control_c == 3} { |
|
puts stderr "signal ctrl-c x3 received - quitting" |
|
flush stderr |
|
after 25 |
|
quit |
|
return 1 |
|
} elseif {$::repl::signal_control_c == 4} { |
|
puts stderr "signal ctrl-c x4 received - one more to hard exit" |
|
flush stderr |
|
return 1 |
|
} elseif {$::repl::signal_control_c >= 5} { |
|
#a script that allows events to be processed could still be running |
|
puts stderr "signal ctrl-c x5 received - hard exit" |
|
flush stderr |
|
after 25 |
|
exit 499 ;# HTTP 'client closed request' - just for the hell of it. |
|
} else { |
|
puts stderr "signal ctrl-c $::repl::signal_control_c received" |
|
flush stderr |
|
#return 0 to fall through to default handler |
|
return 0 |
|
} |
|
} |
|
twapi::set_console_control_handler ::repl::term::handler_console_control |
|
proc ::repl::term::set_console_title {text} { |
|
#go via console - in case ansi disabled/unavailable |
|
punk::console::titleset $text |
|
} |
|
proc ::repl::term::set_console_icon {name} { |
|
#todo |
|
} |
|
#we can't yet emit from an event with proper prompt handling - |
|
#repl::rputs stdout "twapi loaded" |
|
} else { |
|
#repl::rputs stderr " Failed to load twapi" |
|
} |
|
}] |
|
} 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 |
|
#alternatives are \x1b\[?47h ans \x1b[?\47l |
|
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 |
|
|
|
|
|
# moved to punk package.. |
|
#set outdevice [shellfilter::stack::new punkout -settings [list -tag "punkout" -buffering none -raw 1 -syslog [dict get $::punk::config::running syslog_stdout] -file [dict get $::punk::config::running logfile_stdout]]] |
|
#set out [dict get $outdevice localchan] |
|
#set errdevice [shellfilter::stack::new punkerr -settings [list -tag "punkerr" -buffering none -raw 1 -syslog [dict get $::punk::config::running syslog_stderr] -file [dict get $::punk::config::running logfile_stderr]]] |
|
#set err [dict get $errdevice localchan] |
|
|
|
|
|
|
|
# |
|
#set indevice [shellfilter::stack::new commandin -settings {-tag "commandin" -readbuffering line -writebuffering none -raw 1 -direction in}] |
|
#set program_read_stdin_pipe [dict get $indevice localchan] |
|
|
|
|
|
|
|
# unknown -- |
|
# This procedure is called when a Tcl command is invoked that doesn't |
|
# exist in the interpreter. It takes the following steps to make the |
|
# command available: |
|
# |
|
# 1. See if the autoload facility can locate the command in a |
|
# Tcl script file. If so, load it and execute it. |
|
# 2. If the command was invoked interactively at top-level: |
|
# (a) see if the command exists as an executable UNIX program. |
|
# If so, "exec" the command. |
|
# (b) see if the command requests csh-like history substitution |
|
# in one of the common forms !!, !<number>, or ^old^new. If |
|
# so, emulate csh's history substitution. |
|
# (c) see if the command is a unique abbreviation for another |
|
# command. If so, invoke the command. |
|
# |
|
# Arguments: |
|
# args - A list whose elements are the words of the original |
|
# command, including the command name. |
|
|
|
#review - we shouldn't really be doing this |
|
#We need to work out if we can live with the real default unknown and just inject some special cases at the beginning before falling-back to the normal one |
|
|
|
proc ::unknown args { |
|
#puts stderr "unk>$args" |
|
variable ::tcl::UnknownPending |
|
global auto_noexec auto_noload env tcl_interactive errorInfo errorCode |
|
|
|
if {[info exists errorInfo]} { |
|
set savedErrorInfo $errorInfo |
|
} |
|
if {[info exists errorCode]} { |
|
set savedErrorCode $errorCode |
|
} |
|
|
|
set name [lindex $args 0] |
|
if {![info exists auto_noload]} { |
|
# |
|
# Make sure we're not trying to load the same proc twice. |
|
# |
|
if {[info exists UnknownPending($name)]} { |
|
return -code error "self-referential recursion\ |
|
in \"unknown\" for command \"$name\"" |
|
} |
|
set UnknownPending($name) pending |
|
set ret [catch { |
|
auto_load $name [uplevel 1 {::namespace current}] |
|
} msg opts] |
|
unset UnknownPending($name) |
|
if {$ret != 0} { |
|
dict append opts -errorinfo "\n (autoloading \"$name\")" |
|
return -options $opts $msg |
|
} |
|
if {![array size UnknownPending]} { |
|
unset UnknownPending |
|
} |
|
if {$msg} { |
|
if {[info exists savedErrorCode]} { |
|
set ::errorCode $savedErrorCode |
|
} else { |
|
unset -nocomplain ::errorCode |
|
} |
|
if {[info exists savedErrorInfo]} { |
|
set errorInfo $savedErrorInfo |
|
} else { |
|
unset -nocomplain errorInfo |
|
} |
|
set code [catch {uplevel 1 $args} msg opts] |
|
if {$code == 1} { |
|
# |
|
# Compute stack trace contribution from the [uplevel]. |
|
# Note the dependence on how Tcl_AddErrorInfo, etc. |
|
# construct the stack trace. |
|
# |
|
set errInfo [dict get $opts -errorinfo] |
|
set errCode [dict get $opts -errorcode] |
|
set cinfo $args |
|
if {[string length [encoding convertto utf-8 $cinfo]] > 150} { |
|
set cinfo [string range $cinfo 0 150] |
|
while {[string length [encoding convertto utf-8 $cinfo]] > 150} { |
|
set cinfo [string range $cinfo 0 end-1] |
|
} |
|
append cinfo ... |
|
} |
|
set tail "\n (\"uplevel\" body line 1)\n invoked\ |
|
from within\n\"uplevel 1 \$args\"" |
|
set expect "$msg\n while executing\n\"$cinfo\"$tail" |
|
if {$errInfo eq $expect} { |
|
# |
|
# The stack has only the eval from the expanded command |
|
# Do not generate any stack trace here. |
|
# |
|
dict unset opts -errorinfo |
|
dict incr opts -level |
|
return -options $opts $msg |
|
} |
|
# |
|
# Stack trace is nested, trim off just the contribution |
|
# from the extra "eval" of $args due to the "catch" above. |
|
# |
|
set last [string last $tail $errInfo] |
|
if {$last + [string length $tail] != [string length $errInfo]} { |
|
# Very likely cannot happen |
|
return -options $opts $msg |
|
} |
|
set errInfo [string range $errInfo 0 $last-1] |
|
set tail "\"$cinfo\"" |
|
set last [string last $tail $errInfo] |
|
if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} { |
|
return -code error -errorcode $errCode \ |
|
-errorinfo $errInfo $msg |
|
} |
|
set errInfo [string range $errInfo 0 $last-1] |
|
set tail "\n invoked from within\n" |
|
set last [string last $tail $errInfo] |
|
if {$last + [string length $tail] == [string length $errInfo]} { |
|
return -code error -errorcode $errCode \ |
|
-errorinfo [string range $errInfo 0 $last-1] $msg |
|
} |
|
set tail "\n while executing\n" |
|
set last [string last $tail $errInfo] |
|
if {$last + [string length $tail] == [string length $errInfo]} { |
|
return -code error -errorcode $errCode \ |
|
-errorinfo [string range $errInfo 0 $last-1] $msg |
|
} |
|
return -options $opts $msg |
|
} else { |
|
dict incr opts -level |
|
return -options $opts $msg |
|
} |
|
} |
|
} |
|
#set isrepl [expr {[file tail [file rootname [info script]]] eq "repl"}] |
|
set isrepl $::repl::running ;#may not be reading though |
|
if {$isrepl} { |
|
#set ::tcl_interactive 1 |
|
} |
|
if {$isrepl || (([info level] == 1) && (([info script] eq "" ) ) |
|
&& ([info exists tcl_interactive] && $tcl_interactive))} { |
|
if {![info exists auto_noexec]} { |
|
set new [auto_execok $name] |
|
if {$new ne ""} { |
|
set redir "" |
|
if {[namespace which -command console] eq ""} { |
|
set redir ">&@stdout <@stdin" |
|
} |
|
|
|
|
|
#experiment todo - use twapi and named pipes |
|
#twapi::namedpipe_server {\\.\pipe\something} |
|
#Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones |
|
#These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc |
|
# |
|
|
|
if {[string first " " $new] > 0} { |
|
set c1 $name |
|
} else { |
|
set c1 $new |
|
} |
|
|
|
# 'script' command to fake a tty |
|
# note that we lose the exit code from the underlying command by using 'script' if we call shellfilter::run without -e option to script |
|
set scr [auto_execok script] |
|
set scr "" ;#set src to empty to disable - script is just a problematic experiment |
|
if {$scr ne ""} { |
|
#set scriptrun "( $c1 [lrange $args 1 end] )" |
|
|
|
|
|
if 0 { |
|
set scriptrun "( $c1 " |
|
foreach a [lrange $args 1 end] { |
|
if {[string first " " $a] > 0} { |
|
#append scriptrun "\"$a\"" |
|
append scriptrun $a |
|
} else { |
|
append scriptrun $a |
|
} |
|
append scriptrun " " |
|
} |
|
append scriptrun " )" |
|
} |
|
#------------------------------------- |
|
if 0 { |
|
package require string::token::shell |
|
set shellparts [string token shell -indices $args] |
|
|
|
set scriptrun "( $c1 " |
|
foreach info [lrange $shellparts 1 end] { |
|
set type [lindex $info 0] |
|
if {$type eq "D:QUOTED"} { |
|
append scriptrun "\"" |
|
append scriptrun [lindex $info 3] |
|
append scriptrun "\"" |
|
} elseif {$type eq "S:QUOTED"} { |
|
append scriptrun "'" |
|
append scriptrun [lindex $info 3] |
|
append scriptrun "'" |
|
} elseif {$type eq "PLAIN"} { |
|
append scriptrun [lindex $info 3] |
|
} else { |
|
error "Can't interpret '$args' with sh-like syntax" |
|
} |
|
append scriptrun " " |
|
} |
|
append scriptrun " )" |
|
} |
|
|
|
#------------------------------------- |
|
|
|
#uplevel 1 [list ::catch \ |
|
[list ::shellfilter::run [list $scr -q -e -c $scriptrun /dev/null] -teehandle punk -inbuffering line -outbuffering none ] \ |
|
::tcl::UnknownResult ::tcl::UnknownOptions] |
|
if {[string tolower [file rootname [file tail $new]]] ne "script"} { |
|
|
|
if {$::env(SHELL) eq "punk86"} { |
|
set shellcmdflag "punk86 cmdb" |
|
} elseif {$::env(SHELL) eq "cmd"} { |
|
set shellcmdflag "cmd /c" |
|
} elseif {$::env(SHELL) eq "pwsh"} { |
|
set shellcmdflag "pwsh -c" |
|
} else { |
|
# sh etc |
|
#set shellcmdflag "$::env(SHELL) -c" |
|
set shellcmdflag "-c" |
|
} |
|
|
|
|
|
#set commandlist [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not [concat [list $new ] [lrange $args 1 end]]] |
|
set commandlist [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $args $shellcmdflag] |
|
puts stderr ">>> [lindex $commandlist 4]" |
|
} else { |
|
set commandlist [list $new {*}[lrange $args 1 end]] |
|
} |
|
|
|
puts stderr ">>>scriptrun_commandlist: $commandlist" |
|
|
|
#ansiwrap for testing |
|
#set id_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] |
|
uplevel #0 [list ::catch [list ::shellfilter::run $commandlist -teehandle punk -inbuffering line -outbuffering none ] ::tcl::UnknownResult ::tcl::UnknownOptions] |
|
|
|
#shellfilter::stack::remove stderr $id_stderr |
|
|
|
|
|
puts stdout "script result $::tcl::UnknownOptions $::tcl::UnknownResult" |
|
if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { |
|
dict set ::tcl::UnknownOptions -code error |
|
set ::tcl::UnknownResult "Non-zero exit code from command '$args' $::tcl::UnknownResult" |
|
} else { |
|
#no point returning "exitcode 0" if that's the only non-error return. |
|
#It is misleading. Better to return empty string. |
|
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 |
|
#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 \ |
|
[list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle punk -inbuffering line -outbuffering none ] \ |
|
::tcl::UnknownResult ::tcl::UnknownOptions] |
|
|
|
if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { |
|
dict set ::tcl::UnknownOptions -code error |
|
set ::tcl::UnknownResult "Non-zero exit code from command '$args' $::tcl::UnknownResult" |
|
} else { |
|
#no point returning "exitcode 0" if that's the only non-error return. |
|
#It is misleading. Better to return empty string. |
|
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? |
|
# |
|
# - 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 |
|
|
|
} |
|
|
|
foreach id $idlist_stdout { |
|
shellfilter::stack::remove stdout $id |
|
} |
|
foreach id $idlist_stderr { |
|
shellfilter::stack::remove stderr $id |
|
} |
|
} |
|
|
|
|
|
#uplevel 1 [list ::catch \ |
|
# [concat exec $redir $new [lrange $args 1 end]] \ |
|
# ::tcl::UnknownResult ::tcl::UnknownOptions] |
|
|
|
#puts "===exec with redir:$redir $::tcl::UnknownResult ==" |
|
dict incr ::tcl::UnknownOptions -level |
|
return -options $::tcl::UnknownOptions $::tcl::UnknownResult |
|
} |
|
} |
|
if {$name eq "!!"} { |
|
set newcmd [history event] |
|
} elseif {[regexp {^!(.+)$} $name -> event]} { |
|
set newcmd [history event $event] |
|
} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { |
|
set newcmd [history event -1] |
|
catch {regsub -all -- $old $newcmd $new newcmd} |
|
} |
|
if {[info exists newcmd]} { |
|
tclLog $newcmd |
|
history change $newcmd 0 |
|
uplevel 1 [list ::catch $newcmd \ |
|
::tcl::UnknownResult ::tcl::UnknownOptions] |
|
dict incr ::tcl::UnknownOptions -level |
|
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 |
|
} |
|
} |
|
} |
|
#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 { |
|
#punk hacked version - report matches but don't run |
|
if {[llength $cmds]} { |
|
return -code error "unknown command name \"$name\": possible match(es) [lsort $cmds]" |
|
} |
|
|
|
} |
|
|
|
|
|
} |
|
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 |
|
|
|
|
|
|
|
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::get_prompt_config {} { |
|
if {$::tcl_interactive} { |
|
set RST [a] |
|
set resultprompt "[a green bold]-$RST " |
|
set nlprompt "[a green bold].$RST " |
|
set infoprompt "[a green bold]*$RST " |
|
set debugprompt "[a purple bold]~$RST " |
|
} else { |
|
set resultprompt "" |
|
set nlprompt "" |
|
set infoprompt "" |
|
set debugprompt "" |
|
} |
|
return [list resultprompt $resultprompt nlprompt $nlprompt infoprompt $infoprompt debugprompt $debugprompt] |
|
} |
|
proc repl::start {inchan args} { |
|
variable commandstr |
|
variable readingchunk |
|
|
|
# --- |
|
variable editbuf |
|
variable editbuf_list ;#command history |
|
variable editbuf_linenum_submitted |
|
variable editbuf_active_index |
|
# --- |
|
|
|
variable running |
|
variable reading |
|
variable done |
|
set done 0 |
|
variable startinstance |
|
variable loopinstance |
|
if {[namespace exists ::punkapp]} { |
|
if {[dict exists $args -defaultresult]} { |
|
set ::punkapp::default_result [dict get $args -defaultresult] |
|
} |
|
} |
|
incr startinstance |
|
set loopinstance 0 |
|
set running 1 |
|
set commandstr "" |
|
set readingchunk "" |
|
|
|
# --- |
|
set editbuf [punk::repl::class::class_editbuf new {}] |
|
lappend editbuf_list $editbuf ;#current editbuf is always in the history |
|
set editbuf_linenum_submitted 0 |
|
set editbuf_active_index 0 |
|
# --- |
|
|
|
if {$::punk::console::ansi_wanted == 2} { |
|
if {[::punk::console::test_can_ansi]} { |
|
set ::punk::console::ansi_wanted 1 |
|
} else { |
|
set ::punk::console::ansi_wanted -1 |
|
} |
|
} |
|
set prompt_config [get_prompt_config] |
|
doprompt "P% " |
|
fileevent $inchan readable [list [namespace current]::repl_handler $inchan $prompt_config] |
|
set reading 1 |
|
|
|
catch { |
|
#set punk::console::tabwidth [punk::console::get_tabstop_apparent_width] |
|
} |
|
vwait [namespace current]::done |
|
#todo - override exit? |
|
#after 0 ::repl::post_operations |
|
after idle ::repl::post_operations |
|
vwait repl::post_operations_done |
|
if {[namespace exists ::punkapp]} { |
|
#todo check and get punkapp::result array - but what key? |
|
if {[info exists ::punkapp::result(shell)]} { |
|
set temp $::punkapp::result(shell) |
|
unset ::punkapp::result(shell) |
|
return $temp |
|
} elseif {[info exists ::punkapp::default_result]} { |
|
set temp $::punkapp::default_result |
|
unset ::punkapp::default_result |
|
return $temp |
|
} |
|
} |
|
return 0 |
|
} |
|
proc repl::post_operations {} { |
|
if {[info exists ::repl::post_script] && [string length $::repl::post_script]} { |
|
#put aside post_script so the script has the option to add another post_script and restart the repl |
|
set ::repl::running_script $::repl::post_script |
|
set ::repl::post_script "" |
|
uplevel #0 {eval $::repl::running_script} |
|
} |
|
#todo - tidyup so repl could be restarted |
|
set repl::post_operations_done 0 |
|
} |
|
|
|
|
|
proc repl::reopen_stdin {} { |
|
#variable reopen_stdin_attempts |
|
if {$::tcl_platform(platform) eq "windows"} { |
|
puts stderr "|repl> Attempting reconnection of console to stdin by opening 'CON'" |
|
} else { |
|
puts stderr "|repl> Attempting reconnection of console to stdin by opening '/dev/tty'" |
|
} |
|
#puts stderr "channels:[chan names]" |
|
#flush stderr |
|
#catch {chan close stdin} |
|
chan close stdin |
|
|
|
if {$::tcl_platform(platform) eq "windows"} { |
|
#set s [open "CON" r] |
|
set s [open {CONIN$} r] |
|
if {[package provide twapi] ne ""} { |
|
set h [twapi::get_tcl_channel_handle $s in] |
|
twapi::SetStdHandle -10 $h |
|
} |
|
puts stderr "restarting repl on inputchannel:$s" |
|
return [repl::start $s] |
|
} else { |
|
#/dev/tty - reference to the controlling terminal for a process |
|
#review/test |
|
set s [open "/dev/tty" r] |
|
} |
|
|
|
repl::start stdin |
|
} |
|
|
|
proc quit {} { |
|
set ::repl::done "quit" |
|
return "" ;#make sure to return nothing so "quit" doesn't land on stdout |
|
} |
|
|
|
#just a failed experiment.. tried various things |
|
proc repl::reopen_stdinX {} { |
|
#windows - todo unix |
|
package require twapi |
|
|
|
if 0 { |
|
if {[catch {package require Memchan} errM]} { |
|
#package require tcl::chan::fifo2 |
|
#lassign [tcl::chan::fifo2] a b |
|
package require tcl::chan::fifo |
|
set x [tcl::chan::fifo] |
|
} else { |
|
#lassign [fifo2] a b |
|
set x [fifo] |
|
} |
|
#first channel opened after stdin closed becomes stdin |
|
#use a fifo or fifo2 because [chan pipe] assigns the wrong end first! |
|
#a will be stdin |
|
} |
|
#these can't replace proper stdin (filehandle 0) because they're not 'file backed' or 'os level' |
|
#try opening a named pipe server to become stdin |
|
set pipename {\\.\pipe\stdin_%id%} |
|
set pipename [string map [list %id% [pid]] $pipename] |
|
|
|
|
|
|
|
package require tcl::chan::fifo |
|
|
|
chan close stdin |
|
lassign [tcl::chan::fifo] a |
|
|
|
|
|
puts stderr "newchan: $a" |
|
puts stderr "|test> $a [chan conf $a]" |
|
|
|
#set server [twapi::namedpipe_server $pipename] |
|
#set client [twapi::namedpipe_client $pipename] ;#open a client and connect to the server we just made |
|
|
|
puts stderr "chan names: [chan names]" |
|
|
|
#by now $server not valid? |
|
#set server stdin |
|
|
|
#chan configure $server -buffering line -encoding unicode |
|
#chan configure $client -buffering line -encoding unicode |
|
|
|
#puts stderr "|test>ns-server $server [chan conf $server]" |
|
#puts stderr "|test>ns-client $client [chan conf $client]" |
|
|
|
set conin [twapi::get_console_handle stdin] |
|
twapi::set_standard_handle stdin $conin |
|
|
|
set h_in [twapi::get_standard_handle stdin] |
|
|
|
puts stderr "|test> $a [chan conf $a]" |
|
|
|
#chan configure $client -blocking 0 |
|
after 2 repl::start $a |
|
|
|
} |
|
|
|
#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] |
|
return [lindex $screen_last_char_list end 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 |
|
} |
|
#-------------------------------------- |
|
|
|
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 last_char_info [screen_last_char_getinfo] |
|
if {![llength $last_char_info]} { |
|
set needs_clearance 1 |
|
} else { |
|
lassign $last_char_info c what why |
|
if {$why eq "prompt"} { |
|
set needs_clearance 0 |
|
} else { |
|
set needs_clearance [screen_needs_clearance] |
|
#puts -nonewline "-->$needs_clearance $last_char_info" |
|
} |
|
} |
|
if {$needs_clearance == 1} { |
|
set c \n |
|
} else { |
|
set c "" |
|
} |
|
set pre "" |
|
if {[string first \n $prompt] >=0} { |
|
set plines [split $prompt \n] |
|
set pre [join [lrange $plines 0 end-1] \n]\n |
|
set prompt [lindex $plines end] |
|
} |
|
|
|
#this sort of works - but steals some of our stdin data ? review |
|
# |
|
#lassign [punk::console::get_cursor_pos_list] column row |
|
#if {$row != 1} { |
|
# set c "\n" |
|
#} |
|
|
|
set o [a {*}$col] |
|
set r [a] |
|
puts -nonewline stderr $c$pre$o$prompt$r |
|
screen_last_char_add " " "prompt-stderr" prompt |
|
flush stderr |
|
} |
|
} |
|
|
|
#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 |
|
|
|
set pseudo_map [dict create\ |
|
debug stderr\ |
|
debugreport stderr\ |
|
] |
|
|
|
if {[::tcl::mathop::<= 1 [llength $args] 3]} { |
|
set out [lindex $args end] |
|
append out ""; #copy on write |
|
if {([llength $args] > 1) && [lindex $args 0] ne "-nonewline"} { |
|
set this_tail \n |
|
set rputschan [lindex $args 0] |
|
#map pseudo-channels to real |
|
if {$rputschan in [dict keys $pseudo_map]} { |
|
lset args 0 [dict get $pseudo_map $rputschan] |
|
} |
|
} 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] |
|
#map pseudo-channels to real |
|
if {$rputschan in [dict keys $pseudo_map]} { |
|
lset args 0 [dict get $pseudo_map $rputschan] |
|
} |
|
} |
|
set last_char_info_width 60 |
|
#review - string shouldn't be truncated prior to stripcodes - could chop ansi codes! |
|
#set summary "[::shellfilter::ansi::stripcodes [string range $out 0 $last_char_info_width]]" |
|
set out_plain_text [punk::ansi::stripansi $out] |
|
set summary [string range $out_plain_text 0 $last_char_info_width] |
|
if {[string length $summary] > $last_char_info_width} { |
|
append summary " ..." |
|
} |
|
|
|
#make sure we use supplied rputschan in the screen_las_char_add 'what' - which may not be the underlying chan if it was a pseudo |
|
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 |
|
#review - race with copy pasted data, hold-down of enter key |
|
# and data from external process or background script that doesn't go through our stdout filter |
|
#we probably can't use get_cursor_pos - as that needs to emit to stdout and read-loop on stdin which will possibly? make things worse |
|
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 |
|
switch -- $what { |
|
stdout - stderr - stdout/stderr { |
|
return 1 |
|
} |
|
} |
|
return [expr {$c ne "\n"}] |
|
} |
|
|
|
namespace eval repl { |
|
variable startinstance 0 |
|
variable loopinstance 0 |
|
variable loopcomplete 0 |
|
|
|
|
|
variable in_repl_handler [list] |
|
} |
|
|
|
namespace eval punk::repl::class { |
|
oo::class create class_bufman { |
|
|
|
} |
|
|
|
|
|
#multiline editing buffer |
|
oo::class create class_editbuf { |
|
variable o_context |
|
variable o_config |
|
|
|
variable o_rendered_lines |
|
variable o_remaining ;#? |
|
|
|
#o_chunk_list & o_chunk_info should make timed viewing of replays possible |
|
variable o_chunk_list |
|
variable o_chunk_info ;#arrival timing etc |
|
variable o_cursor_row |
|
variable o_cursor_col |
|
variable o_insert_mode |
|
constructor {configdict {contextdict {}}} { |
|
my clear |
|
set o_config $configdict |
|
if {[dict exists $configdict rendered_initialchunk]} { |
|
#pre-rendered initial chunk |
|
#-- |
|
set o_chunk_list "" ;#replace empty chunk from 'clear' call |
|
set o_chunk_info [dict create] |
|
#-- |
|
set ch [dict get $configdict rendered_initialchunk] |
|
my add_rendered_chunk $ch |
|
} |
|
|
|
set o_context $contextdict |
|
#error "[self class].constructor Unable to interpret config '$o_config'" |
|
} |
|
method cursor_row {} { |
|
return $o_cursor_row |
|
} |
|
method cursor_column {} { |
|
return $o_cursor_col |
|
} |
|
method insert_mode {} { |
|
return $o_insert_mode |
|
} |
|
method clear {} { |
|
set o_rendered_lines [list ""] |
|
set o_chunk_list [list] |
|
set o_chunk_info [dict create] |
|
set o_cursor_row 1 |
|
set o_cursor_col 1 |
|
set o_insert_mode 1 ;#default to insert mode |
|
lappend o_chunk_list "" |
|
dict set o_chunk_info 0 [dict create micros [clock microseconds] type rendered] |
|
} |
|
method add_chunk {chunk} { |
|
#we still split on lf - but each physical line may contain horizontal or vertical movements so we need to feed each line in and possibly get an overflow_right and unapplied and cursor-movent return info |
|
lappend o_chunk_list $chunk ;#may contain newlines,horizontal/vertical movements etc - all ok |
|
dict set o_chunk_info [expr {[llength $o_chunk_list] -1}] [dict create micros [clock microseconds] type raw] |
|
if {$chunk eq ""} { |
|
return |
|
} |
|
|
|
set firstnl [string first \n $chunk] |
|
set newparts [split $chunk \n] |
|
#attempt to render new 'lines' into the editbuffer - taking account of active cursor row & col & insertmode |
|
|
|
#merge based on current cursor row and col |
|
#set lastrline [lindex $o_rendered_lines end] |
|
#set n0 [lindex $newparts 0] |
|
#set merged0 [string cat $lastrline $n0] |
|
|
|
#we should merge first row of newparts differently in case our chunks split a grapheme-combination? |
|
# |
|
if {$o_cursor_row < 1} { |
|
puts stderr "add_chunk warning cursor_row < 1 - changing to minimum value 1" |
|
set o_cursor_row 1 |
|
} |
|
set cursor_row_idx [expr {$o_cursor_row -1}] |
|
set activeline [lindex $o_rendered_lines $cursor_row_idx] |
|
set new0 [lindex $newparts 0] |
|
#set combined [string cat $activeline $new0] |
|
#use -cursor_row to tell renderline it's row context. |
|
if {$firstnl >=0} { |
|
#append combined \n |
|
append new0 \n |
|
} |
|
set underlay [punk::ansi::stripansi $activeline] |
|
set line_nextchar_col [expr {[punk::char::string_width $underlay] + 1}] |
|
if {$o_cursor_col > $line_nextchar_col} { |
|
set o_cursor_col $line_nextchar_col |
|
} |
|
|
|
set mergedinfo [overtype::renderline -info 1 -overflow 1 -insert_mode $o_insert_mode -cursor_column $o_cursor_col -cursor_row $o_cursor_row $underlay $new0] |
|
|
|
set result [dict get $mergedinfo result] |
|
set o_insert_mode [dict get $mergedinfo insert_mode] |
|
set result_col [dict get $mergedinfo cursor_column] |
|
set result_row [dict get $mergedinfo cursor_row] |
|
set overflow_right [dict get $mergedinfo overflow_right] ;#should be empty if no \v |
|
set unapplied [dict get $mergedinfo unapplied] |
|
set instruction [dict get $mergedinfo instruction] |
|
|
|
set insert_lines_below [dict get $mergedinfo insert_lines_below] |
|
set insert_lines_above [dict get $mergedinfo insert_lines_above] |
|
|
|
# -- --- --- --- --- --- |
|
set debug_first_row 2 |
|
#puts "merged: $mergedinfo" |
|
set debug "add_chunk0" |
|
append debug \n $mergedinfo |
|
append debug \n "input:[ansistring VIEW -lf 1 -vt 1 $new0] before row:$o_cursor_row after row: $result_row before col:$o_cursor_col after col:$result_col" |
|
package require textblock |
|
set debug [textblock::frame -buildcache 0 $debug] |
|
catch {punk::console::move_emitblock_return $debug_first_row 1 $debug} |
|
# -- --- --- --- --- --- |
|
|
|
set o_cursor_col $result_col |
|
set cursor_row_idx [expr {$o_cursor_row-1}] |
|
lset o_rendered_lines $cursor_row_idx $result |
|
|
|
set nextrow $result_row |
|
switch -- $instruction { |
|
lf_start { |
|
#for normal commandline - we just add a line below |
|
lappend o_rendered_lines "" |
|
incr nextrow |
|
set o_cursor_col 1 |
|
} |
|
} |
|
|
|
if {$insert_lines_below == 1} { |
|
if {[string length $overflow_right]} { |
|
lappend o_rendered_lines $overflow_right |
|
set o_cursor_col [expr {[punk::ansi::printing_length $overflow_right] +1}] |
|
} else { |
|
lappend o_rendered_lines "" |
|
set o_cursor_col 1 |
|
} |
|
} elseif {$insert_lines_above == 1} { |
|
#for {set i 0} {$i < $insert_lines_above} {incr i} { |
|
# set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] |
|
# incr nextrow -1 |
|
#} |
|
set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] |
|
set o_cursor_col 1 |
|
} |
|
|
|
set o_cursor_row $nextrow |
|
set cursor_row_idx [expr {$o_cursor_row-1}] |
|
if {$cursor_row_idx < [llength $o_rendered_lines]} { |
|
set activeline [lindex $o_rendered_lines $cursor_row_idx] |
|
} else { |
|
lappend o_rendered_lines "" |
|
set activeline "" |
|
} |
|
|
|
|
|
set i 1 |
|
foreach p [lrange $newparts 1 end] { |
|
if {$i < [llength $newparts]-1} { |
|
append p \n |
|
} else { |
|
if {$p eq ""} { |
|
break |
|
} |
|
} |
|
#puts stderr "overtype::renderline -info 1 -overflow 1 -insert_mode $o_insert_mode -cursor_column $o_cursor_col -cursor_row $o_cursor_row $activeline '$p'" |
|
set underlay $activeline |
|
set line_nextchar_col [expr {[punk::char::string_width $underlay] + 1}] |
|
if {$o_cursor_col > $line_nextchar_col} { |
|
set o_cursor_col $line_nextchar_col |
|
} |
|
set mergedinfo [overtype::renderline -info 1 -overflow 1 -insert_mode $o_insert_mode -cursor_column $o_cursor_col -cursor_row $o_cursor_row $underlay $p] |
|
set debug "add_chunk$i" |
|
append debug \n $mergedinfo |
|
append debug \n "input:[ansistring VIEW -lf 1 -vt 1 $p]" |
|
package require textblock |
|
set debug [textblock::frame -buildcache 0 $debug] |
|
#catch {punk::console::move_emitblock_return [expr {$debug_first_row + ($i * 6)}] 1 $debug} |
|
|
|
set result [dict get $mergedinfo result] |
|
set o_insert_mode [dict get $mergedinfo insert_mode] |
|
set o_cursor_col [dict get $mergedinfo cursor_column] |
|
set cmove [dict get $mergedinfo cursor_row] |
|
set overflow_right [dict get $mergedinfo overflow_right] ;#should be empty if no \v |
|
set unapplied [dict get $mergedinfo unapplied] |
|
set insert_lines_below [dict get $mergedinfo insert_lines_below] |
|
if {[string is integer -strict $cmove]} { |
|
if {$cmove == 0} { |
|
set nextrow [expr {$o_cursor_row + 1}] |
|
set o_cursor_col 1 |
|
} elseif {$cmove == 1} { |
|
#check for overflow_right and unapplied |
|
#leave cursor_column |
|
} elseif {$cmove >= 1} { |
|
|
|
} |
|
|
|
} else { |
|
# =<int> - absolute |
|
set nextrow [string range $cmove 1 end] |
|
} |
|
if {$nextrow eq $o_cursor_row} { |
|
incr nextrow |
|
} |
|
set o_cursor_row $nextrow |
|
if {$insert_lines_below} { |
|
|
|
} |
|
|
|
set cursor_row_idx [expr {$o_cursor_row-1}] |
|
if {$cursor_row_idx < [llength $o_rendered_lines]} { |
|
set activeline [lindex $o_rendered_lines $cursor_row_idx] |
|
} else { |
|
lappend o_rendered_lines "" |
|
set activeline "" |
|
} |
|
lset o_rendered_lines $cursor_row_idx $result |
|
|
|
incr i |
|
} |
|
|
|
} |
|
method add_rendered_chunk {rchunk} { |
|
#split only on lf newlines - movement codes and \b \v \r not expected |
|
#check only for \v \r as chars we don't expect/want in rendered lines |
|
#chunk as been pre-rendered (or is known to be plain ascii without ANSI or \b \v \r) |
|
#but we don't yet have grapheme split info for it |
|
|
|
if {[regexp {[\v\b\r]} $rchunk]} { |
|
error "[self class].add_rendered_chunk chunk contains \\v or \\b or \\r. Rendered chunk shouldn't contain these characters or ANSI movement codes" |
|
} |
|
lappend o_chunk_list $rchunk ;#rchunk may contain newlines - that's ok |
|
dict set o_chunk_info [expr {[llength $o_chunk_list] -1}] [dict create micros [clock microseconds] type rendered] |
|
|
|
set newparts [split $rchunk \n] |
|
#lappend o_chunk_list $rchunk |
|
set lastrline [lindex $o_rendered_lines end] |
|
|
|
#in renderedlines list merge last line of old with first line of new |
|
#we can't just cat the newpart on to existing rendered line - the chunk could have split a grapheme (e.g char+combiner(s)) |
|
#we |
|
#todo - redo grapheme split on merged line |
|
set merged [string cat $lastrline [lindex $newparts 0]] |
|
lset o_rendered_lines end $merged |
|
|
|
#todo |
|
#each newpart needs its grapheme split info to be stored |
|
set o_rendered_lines [concat $o_rendered_lines [lrange $newparts 1 end]] |
|
|
|
} |
|
method linecount {} { |
|
return [llength $o_rendered_lines] |
|
} |
|
method line {idx} { |
|
if {[string is integer -strict $idx]} { |
|
incr idx -1 |
|
} |
|
return [lindex $o_rendered_lines $idx] |
|
} |
|
method lines {args} { |
|
switch -- [llength $args] { |
|
0 {return $o_rendered_lines} |
|
1 { |
|
set idx [lindex $args 0] |
|
if {[string is integer -strict $idx]} { |
|
incr idx -1 |
|
} |
|
return [list [lindex $o_rendered_lines $idx]] |
|
} |
|
2 { |
|
lassign $args idx1 idx2 |
|
if {[string is integer -strict $idx1]} { |
|
incr idx1 -1 |
|
} |
|
if {[string is integer -strict $idx2]} { |
|
incr idx2 -1 |
|
} |
|
return [lrange $o_rendered_lines $idx1 $idx2] |
|
} |
|
default {error "lines expected 0,1 or 2 indices"} |
|
} |
|
} |
|
|
|
#todo - index base??? |
|
method lines_numbered {args} { |
|
#build a paired list so we don't have to do various calcs on end+ end- etc checking llength |
|
#punk::range will use lseq if available - else use it's own slower code |
|
set max [llength $o_rendered_lines] ;#assume >=1 |
|
set nums [punk::range 1 $max] |
|
set numline_list [list] |
|
foreach n $nums ln $o_rendered_lines { |
|
lappend numline_list [list $n $ln] |
|
} |
|
|
|
switch -- [llength $args] { |
|
0 {return $numline_list} |
|
1 {return [lindex $numline_list [lindex $args 0]]} |
|
2 {return [lrange $numline_list {*}$args]} |
|
default {error "lines expected 0,1 or 2 indices"} |
|
} |
|
} |
|
|
|
#1-based |
|
method delete_line {linenum} { |
|
error "unimplemented" |
|
if {$linenum eq "end"} { |
|
set linenum [llength $o_rendered_lines] |
|
} |
|
if {![string is integer -strict $linenum]} { |
|
error "delete_line accepts only end or an integer from 1 to linecount" |
|
} |
|
if {$linenum == 0} { |
|
error "minimum line is 1" |
|
} |
|
set o_rendered_lines [lreplace $o_rendered_lines $index $index] |
|
} |
|
#clear data from last line only |
|
method clear_tail {} { |
|
set o_cursor_row [llength $o_rendered_lines] |
|
set o_cursor_col 1 |
|
lset o_rendered_lines end "" |
|
} |
|
#1-based |
|
method view_lines {args} { |
|
set llist [my lines {*}$args] |
|
return [join $llist \n] |
|
} |
|
method view_lines_numbered {args} { |
|
set ANSI_linenum [a+ green] |
|
set RST [a] |
|
set llist [my lines_numbered {*}$args] |
|
set nums [lsearch -all -inline -index 0 -subindices $llist *] |
|
lset nums $o_cursor_row-1 "[a+ bold underline]$o_cursor_row${RST}$ANSI_linenum" |
|
set lines [lsearch -all -inline -index 1 -subindices $llist *] |
|
|
|
set cursorline [lindex $lines $o_cursor_row-1] |
|
set charindex_at_cursor [ansistring COLUMNINDEX $cursorline $o_cursor_col] |
|
if {$charindex_at_cursor ne ""} { |
|
lassign [ansistring INDEXCOLUMNS $cursorline $charindex_at_cursor] col0 col1 |
|
#we now have the column extents of the possibly double-wide character at the cursor |
|
#we can apply ansi just to those columns using a transparent overtype |
|
set prefix [string repeat " " [expr {$col0 -1}]] |
|
set linecols [punk::ansi::printing_length $cursorline] |
|
set suffix [string repeat " " [expr {$linecols -$col1}]] |
|
#capitalised INDEX - for grapheme/control-char index e.g a with diacritic a\u0300 has a single index |
|
set char_at_cursor [ansistring INDEX $cursorline $charindex_at_cursor] ;#this is the char with appropriate ansireset codes |
|
set rawchar [punk::ansi::stripansi $char_at_cursor] |
|
if {$rawchar eq " "} { |
|
set charhighlight "[punk::ansi::a+ White]_[a]" |
|
} else { |
|
set charhighlight [punk::ansi::a+ reverse]$char_at_cursor[a] |
|
} |
|
set cursorline [overtype::renderline -transparent 1 -insert_mode 0 -overflow 0 $cursorline $prefix$charhighlight$suffix] |
|
lset lines $o_cursor_row-1 $cursorline |
|
} |
|
|
|
set numcol "$ANSI_linenum[join $nums \n][a]" |
|
set linecol [join $lines \n] |
|
return [textblock::join $numcol " " $linecol] |
|
} |
|
method debugview_lines {} { |
|
set result "" |
|
foreach ln $o_rendered_lines { |
|
append result [ansistring VIEW -lf 1 -vt 1 $ln] \n ;#should be no lf or vt - but if there is.. we'd better show it |
|
} |
|
append result \n "cursor row: $o_cursor_row col: $o_cursor_col" |
|
return $result |
|
} |
|
method last_char {} { |
|
return [string index [lindex $o_chunk_list end] end] |
|
} |
|
|
|
#more strictly - last non-ansi? |
|
method last_grapheme {} { |
|
set lastchunk [lindex $o_chunk_list end] |
|
set plaintext_parts [punk::ansi::ta::split_at_codes $lastchunk] |
|
set pt [lindex $plaintext_parts end] |
|
if {$pt eq ""} { |
|
set pt [lindex $plaintext_parts end-1] |
|
} |
|
set graphemes [punk::char::grapheme_split $pt] |
|
return [lindex $graphemes end] |
|
} |
|
method last_ansi {} { |
|
set lastchunk [lindex $o_chunk_list end] |
|
set parts [punk::ansi::ta::split_codes_single $lastchunk] |
|
set lastcode [lindex $parts end-1] |
|
return $lastcode |
|
#return [ansistring VIEW -lf 1 $lastcode] |
|
} |
|
method chunks {args} { |
|
switch -- [llength $args] { |
|
0 {return $o_chunk_list} |
|
1 {return [lindex $o_chunk_list [lindex $args 0]]} |
|
2 {return [lrange $o_chunk_list {*}$args]} |
|
default {error "chunks expected 0,1 or 2 arguments (index or range)"} |
|
} |
|
} |
|
method view_chunks {} { |
|
set result "" |
|
set dashes [string repeat - 20] |
|
foreach arrival_chunk $o_chunk_list chunk_id [dict keys $o_chunk_info] { |
|
set chunk_info [dict get $o_chunk_info $chunk_id] |
|
append result $dashes \n |
|
set micros [dict get $chunk_info micros] |
|
append result "$chunk_id arrival: [clock format [expr {$micros / 1000000}] -format "%Y-%m-%d %H:%M:%S"] ($micros)" \n |
|
append result $dashes \n |
|
append result $arrival_chunk \n |
|
} |
|
return $result |
|
} |
|
|
|
method debugview_chunks {} { |
|
set result "" |
|
foreach ln $o_chunk_list { |
|
append result [ansistring VIEW -lf 1 -vt 1 $ln] \n |
|
} |
|
append result \n "cursor row: $o_cursor_row col: $o_cursor_col" |
|
return $result |
|
} |
|
method view_raw {} { |
|
return [join $o_chunk_list ""] |
|
} |
|
method debugview_raw {} { |
|
set sublf [ansistring VIEW -lf 1 \n] |
|
#set subvt [ansistring VIEW -lvt 1 \v] ;#vt replacement with $subvt\v will not align accurately.. todo ? |
|
return [string map [list $sublf $sublf\n] [ansistring VIEW -lf 1 -vt 0 [join $o_chunk_list ""]]] |
|
} |
|
} |
|
|
|
} |
|
proc repl::repl_handler_checkchannel {inputchan} { |
|
if {$::repl::signal_control_c > 0 || [chan eof $inputchan]} { |
|
|
|
if {[lindex $::errorCode 0] eq "CHILDKILLED"} { |
|
#rputs stderr "\n|repl> ctrl-c errorCode: $::errorCode" |
|
#avoid spurious triggers after interrupting a command.. |
|
#review - dodgy.. we just want to interrupt child processes but then still be able to interrupt repl |
|
set ::repl::signal_control_c 0 |
|
set preverr [string map [list "child killed" "child_killed"] $::errorInfo] |
|
catch {error $preverr} ;#for errorInfo display |
|
} else { |
|
set ::repl::signal_control_c 0 |
|
fileevent $inputchan readable {} |
|
set reading 0 |
|
set running 0 |
|
if {$::tcl_interactive} { |
|
rputs stderr "\n|repl> EOF on $inputchan." |
|
} |
|
set [namespace current]::done 1 |
|
after 1 [list repl::reopen_stdin] |
|
#tailcall repl::reopen_stdin |
|
} |
|
} |
|
} |
|
proc repl::repl_handler_restorechannel {inputchan previous_input_state} { |
|
if {[chan conf $inputchan] ne $previous_input_state} { |
|
set restore_input_conf [dict remove $previous_input_state -inputmode] ;#Attempting to set input mode often gives permission denied on windows - why? |
|
if {[catch { |
|
chan conf $inputchan {*}$restore_input_conf |
|
} errM]} { |
|
rputs stderr "|repl>original: [ansistring VIEW $previous_input_state]" |
|
rputs stderr "|repl>current : [ansistring VIEW [chan conf $inputchan]]" |
|
rputs stderr "\n|repl> Failed to return $inputchan to original state" |
|
rputs stderr "|repl>ERR: $errM" |
|
} |
|
} |
|
return [chan conf $inputchan] |
|
} |
|
proc repl::repl_handler {inputchan prompt_config} { |
|
variable in_repl_handler |
|
set in_repl_handler [list $inputchan $prompt_config] |
|
|
|
fileevent $inputchan readable {} |
|
upvar ::punk::console::input_chunks_waiting input_chunks_waiting |
|
#note -inputmode not available in Tcl 8.6 for chan configure! |
|
set rawmode 0 |
|
set original_input_conf [chan configure $inputchan] ;#whether repl is in line or raw mode - we restore the stdin state |
|
if {[dict exists $original_input_conf -inputmode]} { |
|
if {[dict get $original_input_conf -inputmode] eq "raw"} { |
|
#user or script has apparently put stdin into raw mode - update punk::console::is_raw to match |
|
set rawmode 1 |
|
set ::punk::console::is_raw 1 |
|
} else { |
|
set ::punk::console::is_raw 0 |
|
} |
|
#what about enable/disable virtualTerminal ? |
|
#using stdin -inputmode to switch modes won't set virtualterminal input state appropriately |
|
#we expect the state of -inputmode to be 'normal' even though we flip it during the read part of our repl loop |
|
#if it's been set to raw - assume it is deliberately done this way as the user could have alternatively called punk::mode raw or punk::console::enableVirtualTerminal |
|
#by not doing this automatically - we assume the caller has a reason. |
|
} else { |
|
set rawmode [set ::punk::console::is_raw] |
|
} |
|
|
|
if {!$rawmode} { |
|
|
|
|
|
#stdin with line-mode readable events (at least on windows for Tcl 8.7a6 to 9.0a) can get stuck with bytes pending when input longer than 100chars - even though there is a linefeed further on than that. |
|
#This potentially affects a reasonable number of Tcl8.7 kit/tclsh binaries out in the wild. |
|
#see bug https://core.tcl-lang.org/tcl/tktview/bda99f2393 (gets stdin problem when non-blocking - Windows) |
|
#when in non-blocking mode we will have to read that in to get further - but we don't know if that was the end of line or if there is more - and we may not get a newline even though one was present originally on stdin. |
|
#presence of 8.7 buffering bug will result in unrecoverable situation - even switching to raw and using read will not be able to retrieve tail data. |
|
#the readable event only gives us 200 bytes (same problem may be at 4k/8k in other versions) |
|
#This occurs whether we use gets or read - |
|
set stdinlines [list] |
|
set linemax 5 ;#not an absolute.. |
|
set lc 0 |
|
if {[dict get $original_input_conf -blocking] ne "0"} { |
|
chan configure $inputchan -blocking 0 |
|
} |
|
|
|
set waitingchunk "" |
|
#review - input_chunks_waiting in line mode - |
|
if {[info exists input_chunks_waiting($inputchan)] && [llength $input_chunks_waiting($inputchan)]} { |
|
#puts stderr "repl_handler input_chunks_waiting($inputchan) while in line mode. Had data:[ansistring VIEW -lf 1 $input_chunks_waiting($inputchan)]" |
|
set allwaiting [join $input_chunks_waiting($inputchan) ""] |
|
set input_chunks_waiting($inputchan) [list] |
|
set yellow [punk::ansi::a+ yellow bold] |
|
set waitinglines [split $allwaiting \n] |
|
foreach ln [lrange $waitinglines 0 end-1] { |
|
lappend stdinlines $ln |
|
incr lc |
|
} |
|
set waitingchunk [lindex $waitinglines end] |
|
# -- |
|
#set chunksize [gets $inputchan chunk] |
|
set chunk [read $inputchan] |
|
set chunksize [string length $chunk] |
|
# -- |
|
if {$chunksize > 0} { |
|
if {[string index $chunk end] eq "\n"} { |
|
lappend stdinlines $waitingchunk[string range $chunk 0 end-1] |
|
#punk::console::cursorsave_move_emitblock_return 30 30 "repl_handler num_stdinlines [llength $stdinlines] chunk:$yellow[ansistring VIEW -lf 1 $chunk][a] fblocked:[fblocked $inputchan] pending:[chan pending input stdin]" |
|
|
|
if {![chan eof $inputchan]} { |
|
repl_handler_restorechannel $inputchan $original_input_conf |
|
} |
|
uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] |
|
} else { |
|
set input_chunks_waiting($inputchan) [list $allwaiting] |
|
lappend input_chunks_waiting($inputchan) $chunk |
|
} |
|
} else { |
|
if {[fblocked $inputchan]} { |
|
#set screeninfo [punk::console::get_size] |
|
#lassign $screeninfo _c cols _r rows |
|
set rows 0 |
|
set cols 3 |
|
if {[string is integer -strict $rows]} { |
|
set RED [punk::ansi::a+ red bold]; set RST [punk::ansi::a] |
|
set msg "${RED}line-length Tcl windows channel bug? Hit enter to continue$RST" |
|
set msglen [ansistring length $msg] |
|
punk::console::cursorsave_move_emitblock_return $rows [expr {$cols - $msglen -1}] $msg |
|
} |
|
after 100 |
|
} |
|
set input_chunks_waiting($inputchan) [list $allwaiting] |
|
} |
|
|
|
} else { |
|
repl_handler_checkchannel $inputchan |
|
# -- --- --- |
|
#set chunksize [gets $inputchan chunk] |
|
# -- --- --- |
|
set chunk [read $inputchan] |
|
set chunksize [string length $chunk] |
|
# -- --- --- |
|
if {$chunksize > 0} { |
|
#punk::console::cursorsave_move_emitblock_return 35 120 "chunk: [ansistring VIEW -lf 1 "...[string range $chunk end-10 end]"]" |
|
set ln $chunk ;#temp |
|
#punk::console::cursorsave_move_emitblock_return 25 30 [textblock::frame -title line "[a+ green]$waitingchunk[a][a+ red][ansistring VIEW -lf 1 $ln][a+ green]pending:[chan pending input stdin][a]"] |
|
if {[string index $ln end] eq "\n"} { |
|
lappend stdinlines [string range $ln 0 end-1] |
|
incr lc |
|
if {![chan eof $inputchan]} { |
|
repl_handler_restorechannel $inputchan $original_input_conf |
|
} |
|
uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] |
|
} else { |
|
lappend input_chunks_waiting($inputchan) $ln |
|
} |
|
} |
|
} |
|
|
|
} else { |
|
if {[info exists input_chunks_waiting($inputchan)] && [llength $input_chunks_waiting($inputchan)]} { |
|
#we could concat and process as if one chunk - but for now at least - we want to preserve the 'chunkiness' |
|
set wchunks $input_chunks_waiting($inputchan) |
|
set ch [lindex $wchunks 0] |
|
set input_chunks_waiting($inputchan) [lrange $wchunks 1 end] |
|
|
|
uplevel #0 [list repl::repl_process_data $inputchan raw-waiting $ch [list] $prompt_config] |
|
|
|
} else { |
|
|
|
repl_handler_checkchannel $inputchan |
|
if {[dict get $original_input_conf -blocking] ne "0" || [dict get $original_input_conf -translation] ne "lf"} { |
|
chan configure $inputchan -blocking 0 |
|
chan configure $inputchan -translation lf |
|
} |
|
set chunk [read $inputchan] |
|
|
|
if {![chan eof $inputchan]} { |
|
repl_handler_restorechannel $inputchan $original_input_conf |
|
} |
|
uplevel #0 [list repl::repl_process_data $inputchan raw-read $chunk [list] $prompt_config] |
|
while {[join $input_chunks_waiting($inputchan)] ne ""} { |
|
#puts "...[llength $input_chunks_waiting($inputchan)]" |
|
set wchunks $input_chunks_waiting($inputchan) |
|
set ch [lindex $wchunks 0] |
|
set input_chunks_waiting($inputchan) [lrange $wchunks 1 end] |
|
uplevel #0 [list repl::repl_process_data $inputchan raw-waiting $ch [list] $prompt_config] |
|
} |
|
} |
|
} |
|
|
|
|
|
|
|
if {![chan eof $inputchan]} { |
|
|
|
################################################################################## |
|
#Re-enable channel read handler only if no waiting chunks - must process in order |
|
################################################################################## |
|
if {![llength $input_chunks_waiting($inputchan)]} { |
|
fileevent $inputchan readable [list ::repl::repl_handler $inputchan $prompt_config] |
|
} else { |
|
after idle [list ::repl::repl_handler $inputchan $prompt_config] |
|
} |
|
#################################################### |
|
} else { |
|
#rputs stderr "repl_handler EOF inputchannel:[chan conf $inputchan]" |
|
repl_handler_checkchannel $inputchan |
|
} |
|
set in_repl_handler [list] |
|
} |
|
proc repl::editbuf {index args} { |
|
variable editbuf_list |
|
set editbuf [lindex $editbuf_list $index] |
|
if {$editbuf ne ""} { |
|
$editbuf {*}$args |
|
} else { |
|
return "No such index in editbuf list" |
|
} |
|
} |
|
interp alias {} editbuf {} ::repl::editbuf |
|
proc repl::repl_process_data {inputchan type chunk stdinlines prompt_config} { |
|
variable loopinstance |
|
variable loopcomplete |
|
incr loopinstance |
|
set moredata 0 |
|
upvar ::punk::console::input_chunks_waiting input_chunks_waiting |
|
|
|
try { |
|
variable prompt_reset_flag |
|
#catch {puts stderr "xx--->[rep $::arglej]"} |
|
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 cursorcolumn "" |
|
variable commandstr |
|
# --- |
|
variable editbuf |
|
variable editbuf_list |
|
variable editbuf_linenum_submitted |
|
|
|
# --- |
|
variable readingchunk |
|
variable running |
|
variable reading |
|
variable post_script |
|
variable id_outstack |
|
upvar ::punk::last_run_display last_run_display |
|
upvar ::punk::config::running running_config |
|
|
|
|
|
set resultprompt [dict get $prompt_config resultprompt] |
|
set nlprompt [dict get $prompt_config nlprompt] |
|
set infoprompt [dict get $prompt_config infoprompt] |
|
set debugprompt [dict get $prompt_config debugprompt] |
|
|
|
|
|
#JMN |
|
#fileevent $inputchan readable {} |
|
|
|
|
|
#According to DKF - -buffering option doesn't affect input channels |
|
|
|
if {$cursorcolumn eq ""} { |
|
set cursorcolumn 1 |
|
} |
|
|
|
|
|
# -- --- --- |
|
#for raw mode |
|
set chunkreadsize 1024 |
|
set maxreads 4 |
|
set linemax 40 ;#max number of lines received for us to read another chunk in same loop - *not a limit on number of lines in a round* |
|
#Note - we could read for example 1024 lines if they fit in our chunk read size - and we'll have to process them all, but if 1024 > $linemax we won't read more available data in this round. |
|
# -- --- --- |
|
|
|
|
|
set rawmode [set ::punk::console::is_raw] |
|
if {!$rawmode} { |
|
#puts stderr "-->got [ansistring VIEW -lf 1 $stdinlines]<--" |
|
|
|
} else { |
|
#raw |
|
set numreads 0 |
|
set lc 0 |
|
set onetime 1 |
|
while {$onetime && [string length $chunk] >= 0 } { |
|
set onetime 0 |
|
set chunklen [string length $chunk] |
|
#punk::console::move_emitblock_return 20 120 $chunklen-->[chan conf stdin]<-- |
|
if {$chunklen > 0} { |
|
set info1 "read $chunklen bytes->[ansistring VIEW -lf 1 -vt 1 $chunk]" |
|
#consider also the terminal linefeed mode. |
|
#https://vt100.net/docs/vt510-rm/LNM.html |
|
# terminals (by default) generally use a lone cr to represent enter (LNM reset ie CSI 20l) |
|
#(as per above doc: "For compatibility with Digital's software you should keep LNM reset (line feed)") |
|
|
|
#You can insert an lf using ctrl-j - and of course stdin could have crlf or lf |
|
#pasting from notepad++ with mixed line endings seems to paste everything ok |
|
#we don't really know the source of input keyboard vs paste vs pipe - and whether a read has potentially chopped a crl in half.. |
|
#possibly no real way to determine that. We could wait a small time to see if there's more data coming.. and potentially impact performance. |
|
#Instead we'll try to make sense of it here. |
|
|
|
if {$chunklen == 1} { |
|
#presume it's a keypress from terminal |
|
set chunk [string map [list \r \n] $chunk] |
|
} else { |
|
#maybe a paste? (or stdin to active shell loop - possibly with no terminal ? ) |
|
#we'd better check for crlf and/or plain lf. If found - presume any lone CR is to be left as is. |
|
if {[string first \n $chunk] < 0} { |
|
set chunk [string map [list \r \n] $chunk] |
|
} |
|
#else - |
|
#has lf - but what if last char is cr? |
|
#It may require user to hit enter - probably ok. |
|
#could be a sequence of cr's from holding enter key |
|
} |
|
|
|
#review - we can receive chars such as escapes or arrow inline with other data even from keyboard if keys are pushed quickly (or automated?) |
|
# - so we probably shouldn't really rely on whether a char arrives alone in a chunk as a factor in its behaviour |
|
#On the other hand - timing of keystrokes could be legitimate indications of intention in a cli ? |
|
|
|
#esc or ctrl-lb |
|
if {$chunk eq "\x1b"} { |
|
#return |
|
#set readingchunk "" |
|
set stdinlines [list "\x1b"] |
|
set commandstr "" |
|
set chunk "" |
|
$editbuf clear_tail |
|
screen_last_char_add \x1b stdin escape |
|
break |
|
} |
|
|
|
#if ProcessedInput is disabled - we can get ctrl-c |
|
#e.g with punk::console::disableProcessedInput |
|
#if we get just ctrl-c in one chunk |
|
#ctrl-c |
|
if {$chunk eq "\x03"} { |
|
#::repl::term::handler_console_control "ctrl-c_via_rawloop" |
|
error "character 03 -> ctrl-c" |
|
} |
|
#for now - exit with small delay for tidyup |
|
#ctrl-z |
|
if {$chunk eq "\x1a"} { |
|
#::repl::term::handler_console_control "ctrl-z_via_rawloop" |
|
punk::mode line |
|
after 1000 exit |
|
return |
|
} |
|
if {$chunk eq "\x7f"} { |
|
set chunk "\b\x7f" |
|
} |
|
#ctrl-bslash |
|
if {$chunk eq "\x1c"} { |
|
#try to brutally terminate process |
|
#attempt to leave terminal in a reasonable state |
|
punk::mode line |
|
after 200 {exit 42} |
|
} |
|
|
|
if {$chunk eq "\x1b\[D"} { |
|
#move cursor record within our buffer |
|
#rputs stderr "${debugprompt}arrow-left D" |
|
#set commandstr "" |
|
#punk::console::move_back 1 ;#terminal does it anyway? |
|
} |
|
|
|
$editbuf add_chunk $chunk |
|
|
|
#-------------------------- |
|
if {[set ::punk::console::ansi_available]} { |
|
package require textblock |
|
#experimental - use punk::console::get_size to determine current visible width. |
|
#This should ideally be using sigwinch or some equivalent to set a value somewhere. |
|
#testing each time is very inefficient (1+ms) |
|
#unfortunately there isn't an easy way to get such an event on windows console based systems - REVIEW. |
|
set do_checkwidth 1 ;#make configurable if performance hit is too severe? TODO |
|
if {$do_checkwidth} { |
|
set consolewidth [dict get [punk::console::get_size] columns] |
|
} else { |
|
set consolewidth 132 ;#todo - something better! |
|
} |
|
set debug_width 0 |
|
if {$::punk::repl::debug_repl > 0} { |
|
set lastc [string index $chunk end] |
|
set lastc [ansistring VIEW -lf 1 -vt 1 $lastc] |
|
if {[string length $lastc]} { |
|
#set info [textblock::frame [textblock::block 10 10 $lastc]] |
|
} |
|
if {[catch { |
|
set info [$editbuf debugview_raw] |
|
if {$type eq "raw-waiting"} { |
|
set info [a+ bold yellow]$info[a] |
|
} else { |
|
set info [a+ green]$info[a] |
|
} |
|
set lines [lines_as_list -ansiresets 1 $info] |
|
if {[llength $lines] > 20} { |
|
set lines [lrange $lines end-19 end] |
|
set info [list_as_lines $lines] |
|
} |
|
} errM]} { |
|
set info [textblock::frame -buildcache 0 -title "[a red]error[a]" $errM] |
|
} else { |
|
set info [textblock::frame -buildcache 0 -ansiborder [a+ green bold] -title "[a cyan]debugview_raw[a]" $info] |
|
} |
|
set debug_width [textblock::widthtopline $info] |
|
set spacepatch [textblock::block $debug_width 2 " "] |
|
puts -nonewline [punk::ansi::cursor_off] |
|
#use non cursorsave versions - cursor save/restore will interfere with any concurrent ansi rendering that uses save/restore - because save/restore is a single item, not a stack. |
|
set debug_offset [[expr {$consolewidth - $debug_width - 2}]] |
|
punk::console::move_emitblock_return 8 $debug_offset $spacepatch |
|
punk::console::move_emitblock_return 10 $debug_offset $info |
|
puts -nonewline [punk::ansi::cursor_on] |
|
} |
|
if {[catch { |
|
#set info [$editbuf view_lines] |
|
set info [$editbuf view_lines_numbered] |
|
set lines [lines_as_list -ansiresets 1 $info] |
|
if {[llength $lines] > 20} { |
|
set lines [lrange $lines end-19 end] |
|
set info [list_as_lines $lines] |
|
} |
|
} editbuf_error]} { |
|
set info [textblock::frame -buildcache 0 -title "[a red]error[a]" "$editbuf_error\n$::errorInfo"] |
|
} else { |
|
set title "[a cyan]editbuf [expr {[llength $editbuf_list]-1}] lines [$editbuf linecount][a]" |
|
append title "[a+ yellow bold] col:[format %3s [$editbuf cursor_column]] row:[$editbuf cursor_row][a]" |
|
set row1 " lastchar:[ansistring VIEW -lf 1 [$editbuf last_char]] lastgrapheme:[ansistring VIEW -lf 1 [$editbuf last_grapheme]]" |
|
set row2 " lastansi:[ansistring VIEW -lf 1 [$editbuf last_ansi]]" |
|
set info [a+ green bold]$row1\n$row2[a]\n$info |
|
set info [textblock::frame -buildcache 0 -ansiborder [a+ green bold] -title $title $info] |
|
} |
|
set editbuf_width [textblock::widthtopline $info] |
|
set spacepatch [textblock::block $editbuf_width 2 " "] |
|
|
|
set editbuf_offset [expr {$consolewidth - $debug_width - $editbuf_width - 2}] |
|
punk::console::cursorsave_move_emitblock_return 8 $editbuf_offset $spacepatch |
|
punk::console::cursorsave_move_emitblock_return 10 $editbuf_offset $info |
|
} |
|
|
|
|
|
set lines_unsubmitted [expr {[$editbuf linecount] - $editbuf_linenum_submitted}] |
|
#there is always one 'line' unsubmitted - although it may be the current one being built, which may be empty string |
|
if {$lines_unsubmitted < 1} { |
|
puts stderr "repl editbuf_linenum_submitted out of sync with editbuf" |
|
} |
|
|
|
#set trailing_line_index [expr {[$editbuf linecount] -1}] |
|
set last_line_num [$editbuf linecount] |
|
#set nextsubmit_index [expr {$editbuf_lineindex_submitted + 1}] |
|
set nextsubmit_line_num [expr {$editbuf_linenum_submitted + 1}] |
|
|
|
set cursor_row [$editbuf cursor_row] |
|
set cursor_index [expr {$cursor_row -1}] |
|
set lastansi [$editbuf last_ansi] |
|
if {$lastansi eq "\x1b\[A"} { |
|
if {$cursor_row > 1} { |
|
puts -nonewline stdout "\x1b\[A" |
|
} |
|
} elseif {$lastansi eq "\x1b\[B"} { |
|
puts -nonewline stdout "\x1b\[B" |
|
} |
|
flush stdout |
|
|
|
|
|
|
|
set offset 3 |
|
puts -nonewline stdout [a+ cyan][punk::ansi::move_column [expr {$offset +1}]][punk::ansi::erase_eol][$editbuf line $cursor_row][a][punk::ansi::move_column [expr {$offset + [$editbuf cursor_column]}]] |
|
#puts -nonewline stdout $chunk |
|
flush stdout |
|
if {[$editbuf last_char] eq "\n"} { |
|
set linelen [punk::ansi::printing_length [$editbuf line $nextsubmit_line_num]] |
|
puts -nonewline stdout [a+ cyan bold][punk::ansi::move_column [expr {$offset +1}]][$editbuf line $nextsubmit_line_num][a][punk::ansi::move_column [expr {$offset + $linelen +1}]] |
|
#screen_last_char_add "\n" input inputline |
|
puts -nonewline stdout [punk::ansi::erase_eol]\n |
|
#puts -nonewline stdout \n |
|
screen_last_char_add "\n" input inputline |
|
set waiting [$editbuf line end] |
|
if {[string length $waiting] > 0} { |
|
set waiting [a+ yellow bold]$waiting[a] |
|
#puts stderr "waiting $waiting" |
|
$editbuf clear_tail |
|
lappend input_chunks_waiting($inputchan) $waiting |
|
} |
|
} |
|
if {$editbuf_linenum_submitted == 0} { |
|
#(there is no line 0 - lines start at 1) |
|
if {[$editbuf last_char] eq "\n"} { |
|
lappend stdinlines [$editbuf line 1] |
|
incr lc |
|
set editbuf_linenum_submitted 1 |
|
} |
|
} else { |
|
if {$nextsubmit_line_num < $last_line_num} { |
|
foreach ln [$editbuf lines $nextsubmit_line_num end-1] { |
|
lappend stdinlines $ln |
|
incr lc |
|
incr editbuf_linenum_submitted |
|
} |
|
} |
|
} |
|
set last_cursor_column [$editbuf cursor_column] |
|
} else { |
|
#rputs stderr "->0byte read stdin" |
|
if {[chan eof $inputchan]} { |
|
fileevent $inputchan readable {} |
|
set reading 0 |
|
set running 0 |
|
if {$::tcl_interactive} { |
|
rputs stderr "\n|repl> EOF on $inputchan." |
|
} |
|
set [namespace current]::done 1 |
|
#test |
|
#JMN |
|
#tailcall repl::reopen_stdin |
|
} |
|
#break |
|
|
|
} |
|
} |
|
} |
|
|
|
|
|
set maxlinenum [expr {[llength $stdinlines] -1}] |
|
set linenum 0 |
|
foreach line $stdinlines { |
|
#puts stderr "----->line: [ansistring VIEW -lf 1 $line] commandstr:[ansistring VIEW -lf 1 $commandstr]" |
|
set last_repl_char "" ;#last char emitted by this handler to stdout/stderr |
|
set lastoutchar "" |
|
set lasterrchar "" |
|
|
|
|
|
#consider \x1b as text on console vs \x1b the character |
|
#review - if we're getting these actual escape characters in line mode.. something is off - let's emit something instead of trying to interpret as a command and failing. |
|
#This tends to happen when some sort of readline not avaialbe ie on unix or mintty in windows |
|
#this only captures leading escape.. as an aid to diagnosis e.g <sp><right-arrow> won't be caught and the user will need to close the right bracket to complete the bogus command |
|
#we may need to think about legitimate raw escapes in commands e.g from pipes or script files, vs via console? |
|
|
|
#esc key or ctrl-lb followed by enter |
|
if {$line eq "\x1b"} { |
|
#abort current command |
|
if {$linenum == 0} { |
|
doprompt "E% " {yellow bold} |
|
set line "" |
|
#screen_last_char_add " " empty empty |
|
} else { |
|
doprompt "\nE% " {yellow bold} |
|
#screen_last_char_add "\n" empty empty ;#add \n to indicate noclearance required |
|
} |
|
incr linenum |
|
continue |
|
} else { |
|
if {$line eq "\x1b\[C"} { |
|
rputs stderr "${debugprompt}arrow-right C" |
|
#set commandstr "" |
|
} |
|
if {$line eq "\x1b\[D"} { |
|
#rputs stderr "${debugprompt}arrow-left D" |
|
#set commandstr "" |
|
#punk::console::move_back 1 |
|
} |
|
if {$line eq "\x1b\[A"} { |
|
rputs stderr "${debugprompt}arrow-up A" |
|
} |
|
if {$line eq "\x1b\[B"} { |
|
rputs stderr "arrow-down B" |
|
} |
|
if {[string match "\x1b*" $line]} { |
|
rputs stderr "${debugprompt}esc - '[punk::ansi::ansistring::VIEW $line]'" |
|
#set commandstr [punk::ansi::stripansi $commandstr] |
|
} |
|
} |
|
|
|
if {$commandstr ne ""} { |
|
append commandstr \n |
|
} |
|
|
|
set stdinconf [fconfigure $inputchan] |
|
if {$::tcl_platform(platform) eq "windows" && [dict get $stdinconf -encoding] ni [list unicode utf-16 utf-8]} { |
|
#some long console inputs are split weirdly when -encoding and -translation are left at defaults - requiring extra enter-key to get repl to process. |
|
#experiment to see if using binary and handling line endings manually gives insight. |
|
# - do: chan conf stdin -encoding binary -translation lf |
|
|
|
#first command after configuring stdin this way seems to be interpreted with wrong encoding - subsequent commands work - review |
|
|
|
#this branch only works on tcl8.7+ |
|
#It seems to fix the issue with holding down enter-key and getting extra blank lines, but |
|
# it breaks copy-paste (encoding issue?) |
|
|
|
|
|
#puts "--inputchan:$inputchan> [fconfigure $inputchan]" |
|
|
|
append commandstr $line |
|
puts "1=============>[string length $commandstr] bytes , [ansistring VIEW $commandstr] , info complete:[info complete $line] stdinconf:$stdinconf" |
|
set commandstr [string range $commandstr 0 end-3] |
|
set commandstr [encoding convertfrom utf-16be $commandstr] ;#This is weird - but it seems to be big endian? |
|
set commandstr [string trimright $commandstr] |
|
#puts "2=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" |
|
} else { |
|
#append commandstr $line |
|
#puts "0=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" |
|
append commandstr $line |
|
} |
|
|
|
#puts "=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" |
|
set ::repl::last_repl_char "\n" ;#this is actually the eol from stdin |
|
screen_last_char_add "\n" stdin $line |
|
|
|
|
|
|
|
#append commandstr \n |
|
|
|
|
|
if {[info complete $commandstr] && [string index $commandstr end] ne "\\"} { |
|
#set commandstr [overtype::renderline -overflow 1 "" $commandstr] |
|
|
|
|
|
set ::repl::output_stdout "" |
|
set ::repl::output_stderr "" |
|
set outstack [list] |
|
set errstack [list] |
|
|
|
|
|
#oneshot repl debug |
|
set wordparts [regexp -inline -all {\S+} $commandstr] |
|
lassign $wordparts cmd_firstword cmd_secondword |
|
if {$cmd_firstword eq "debugrepl"} { |
|
if {$cmd_secondword in [list 0 cancel]} { |
|
set ::punk::repl::debug_repl 0 |
|
} else { |
|
if {[string is integer -strict $cmd_secondword]} { |
|
incr ::punk::repl::debug_repl $cmd_secondword |
|
} else { |
|
incr ::punk::repl::debug_repl |
|
} |
|
} |
|
set commandstr "set ::punk::repl::debug_repl" |
|
} |
|
if {$::punk::repl::debug_repl > 100} { |
|
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 "" |
|
} |
|
#use pseudo-channel debugreport |
|
rputs debugreport $clearance$p[string map [list \n \n$p] $msg] |
|
}] |
|
set info "" |
|
append info "repl loopinstance: $loopinstance debugrepl remaining: [expr {[set ::punk::repl::debug_repl]-1}]\n" |
|
append info "commandstr: [punk::ansi::ansistring::VIEW $commandstr]\n" |
|
append info "last_run_info\n" |
|
append info "length: [llength $::punk::last_run_display]\n" |
|
append info "namespace: $::punk::ns::ns_current" |
|
debug_repl_emit $info |
|
} else { |
|
proc debug_repl_emit {msg} {return} |
|
} |
|
|
|
#----------------------------------------- |
|
#review! |
|
#work around weird behaviour in tcl 8.6 & 8.7a5 (at least) part1 |
|
#https://wiki.tcl-lang.org/page/representation |
|
#/scriptlib/tests/listrep_bug.tcl |
|
#after the uplevel #0 $commandstr call |
|
# vars within the script that were set to a list, and have no string-rep, will generate a string-rep once the script (commandstr) is unset, or set to another value |
|
global run_command_string |
|
set run_command_string "$commandstr\n" ;#add anything that won't affect script. |
|
global run_command_cache |
|
#----------------------------------------- |
|
|
|
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::console::colour]} { |
|
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]] && [punk::console::colour]} { |
|
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 |
|
#JMN |
|
fileevent $inputchan readable {} |
|
set reading 0 |
|
#don't let unknown use 'args' to convert commandstr to list |
|
#=============================================================================== |
|
#Actual command call |
|
#puts "____>[rep $commandstr]" |
|
#=============================================================================== |
|
if {[string equal -length [string length "repl_runraw "] "repl_runraw " $commandstr]} { |
|
#pass unevaluated command to runraw |
|
set status [catch {uplevel #0 [list runraw $commandstr]} raw_result] |
|
} else { |
|
#puts stderr "repl uplevel 0 '$run_command_string'" |
|
set status [catch { |
|
#uplevel 1 $run_command_string |
|
#uplevel 1 {namespace eval $::punk::ns::ns_current $run_command_string} |
|
set weirdns 0 |
|
set parts [punk::ns::nsparts $::punk::ns::ns_current] |
|
foreach p $parts { |
|
if {[string match :* $p] || [string match *: $p]} { |
|
set weirdns 1 |
|
break |
|
} |
|
} |
|
|
|
if {$weirdns} { |
|
uplevel 1 {punk::ns::nseval $::punk::ns::ns_current $run_command_string} |
|
} else { |
|
#puts stderr "--> [ansistring VIEW -lf 1 -vt 1 $run_command_string] <--" |
|
uplevel 1 {namespace inscope $::punk::ns::ns_current $run_command_string} |
|
} |
|
} raw_result] |
|
} |
|
#puts stderr "repl raw_result: $raw_result" |
|
#set result $raw_result |
|
#append result ""; #copy on write |
|
#copy on write |
|
|
|
#append result $raw_result "" |
|
set result [string cat $raw_result ""] |
|
#puts stderr "-->>$result<--" |
|
#=============================================================================== |
|
flush stdout |
|
flush stderr |
|
foreach s [lreverse $outstack] { |
|
shellfilter::stack::remove stdout $s |
|
} |
|
foreach s [lreverse $errstack] { |
|
shellfilter::stack::remove stderr $s |
|
} |
|
|
|
#----------------------------------------- |
|
#list/string-rep bug workaround part 2 |
|
#todo - set flag based on punk::repl::has_script_var_bug |
|
lappend run_command_cache $run_command_string |
|
#puts stderr "run_command_string rep: [rep $run_command_string]" |
|
if {[llength $run_command_cache] > 2000} { |
|
set run_command_cache [lrange $run_command_cache 1750 end] |
|
} |
|
#----------------------------------------- |
|
|
|
set lastoutchar [string index [punk::ansi::stripansi $::repl::output_stdout] end] |
|
set lasterrchar [string index [punk::ansi::stripansi $::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 $line] |
|
} { |
|
#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 |
|
if {$::punk::repl::debug_repl > 0} { |
|
set lastcharinfo "\n" |
|
set whatcol [string repeat " " 12] |
|
foreach cinfo $::repl::screen_last_char_list { |
|
lassign $cinfo c whatinfo whyinfo |
|
set cdisplay [punk::ansi::ansistring::VIEW -lf 1 -vt 1 $c] |
|
#assertion cdisplay has no raw newlines |
|
if {[punk::char::ansifreestring_width $cdisplay] == 1} { |
|
set cdisplay "$cdisplay " ;#make 2 wide |
|
} |
|
if {[string match repl-debugreport* $whatinfo]} { |
|
#exclude noise debug_repl_emit - but still show the last_char |
|
set whysummary "" |
|
} else { |
|
#set whysummary [string map [list \n "-n-"] $whyinfo] |
|
set whysummary [punk::ansi::ansistring::VIEW -lf 1 -vt 1 $whyinfo] |
|
} |
|
set whatinfo [string range $whatinfo$whatcol 0 [string length $whatcol]] |
|
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 "<output>'$::repl::output_stdout' lastoutchar:'$lastoutchar' result:'$result'" |
|
#$command is an unevaluated script at this point |
|
# so may not be a well formed list e.g 'set x [list a "b"]' |
|
#- lindex will fail |
|
#if {[lindex $command 0] eq "runx"} {} |
|
|
|
|
|
if { |
|
[string equal -length [string length "d/ "] "d/ " $commandstr] || \ |
|
[string equal "d/\n" $commandstr] || \ |
|
[string equal -length [string length "dd/ "] "dd/ " $commandstr] || \ |
|
[string equal "dd/\n" $commandstr] || \ |
|
[string equal -length [string length "./ "] "./ " $commandstr] || \ |
|
[string equal "./\n" $commandstr] || \ |
|
[string equal -length [string length "../ "] "../ " $commandstr] || \ |
|
[string equal "../\n" $commandstr] || \ |
|
[string equal -length [string length "runx "] "runx " $commandstr] || \ |
|
[string equal -length [string length "sh_runx "] "sh_runx " $commandstr] || \ |
|
[string equal -length [string length "runout "] "runout " $commandstr] || \ |
|
[string equal -length [string length "sh_runout "] "sh_runout " $commandstr] || \ |
|
[string equal -length [string length "runerr "] "runerr " $commandstr] || \ |
|
[string equal -length [string length "sh_runerr "] "sh_runerr " $commandstr] |
|
|
|
} { |
|
if {[llength $last_run_display]} { |
|
set result $last_run_display |
|
set result_is_chunk_list 1 |
|
} |
|
} |
|
|
|
# -- --- --- --- --- --- --- --- --- --- |
|
##an attempt to preserve underlying rep |
|
##this is not for performance - just to be less disruptive to underlying rep to aid in learning/debugging |
|
# -- --- --- --- --- --- --- --- --- --- |
|
# JN 2023 - The lrange operation is destructive to path intrep |
|
# The lrange operation is destructive to strings with leading/trailing newlines |
|
# -- --- --- --- --- --- --- --- --- --- |
|
#set saved_errorCode $::errorCode |
|
#set saved_errorInfo $::errorInfo |
|
#if {[catch {lrange $result 0 end} result_as_list]} { |
|
# set is_result_empty [expr {$result eq ""}] |
|
# set ::errorCode $saved_errorCode |
|
# set ::errorInfo $saved_errorInfo |
|
#} else { |
|
# set is_result_empty [expr {[llength $result_as_list] == 0}] |
|
#} |
|
# -- --- --- --- --- --- --- --- --- --- |
|
#set resultrep [::tcl::unsupported::representation $result] |
|
|
|
set is_result_empty [expr {$result eq ""}] |
|
|
|
#catch {puts stderr "yy--->[rep $::arglej]"} |
|
|
|
set reading 1 |
|
if {!$is_result_empty} { |
|
if {$status == 0} { |
|
if {[screen_needs_clearance]} { |
|
rputs -nonewline stderr \n |
|
} |
|
if {$result_is_chunk_list} { |
|
foreach c $result { |
|
lassign $c termchan text |
|
if {[string length $text]} { |
|
switch -- $termchan { |
|
result { |
|
#rputs stdout $resultprompt[string map [list \n "\n$resultprompt"] $text] |
|
set h [textblock::height $text] |
|
set promptcol [string repeat $resultprompt\n $h] |
|
set promptcol [string range $promptcol 0 end-1] |
|
rputs [textblock::join -- $promptcol $text] |
|
|
|
#puts -nonewline stdout $text |
|
} |
|
resulterr { |
|
rputs stderr $resultprompt[string map [list \n "\n$resultprompt"] $text] |
|
} |
|
info { |
|
rputs stderr $infoprompt[string map [list \n "\n$infoprompt"] $text] |
|
} |
|
default { |
|
#rputs -nonewline $termchan $text |
|
set chanprompt "_ " |
|
rputs $termchan ${chanprompt}[string map [list \n "\n${chanprompt}"] $text] |
|
} |
|
} |
|
} |
|
} |
|
|
|
} else { |
|
#----------------------------------------------------------- |
|
# avoid repl forcing string rep of simple results. This is just to aid analysis using tcl::unsupported::representation |
|
#set rparts [split $result {}] |
|
#if {[lsearch $rparts \n] < 0} { |
|
# #type of $result unaffected |
|
# rputs "$resultprompt $result" |
|
#} else { |
|
# #$result will be a string due to use of string map |
|
# rputs $resultprompt[string map [list \n "\n$resultprompt"] $result] |
|
#} |
|
#----------------------------------------------------------- |
|
|
|
#we have copied rawresult using append with empty string - so our string interaction with result var here shouldn't affect the returned value |
|
#empty-string result handled in other branch |
|
set flat [string map [list \r\n "" \n ""] $result] |
|
if {[string length $flat] == [string length $result]} { |
|
#no line-endings in data |
|
rputs "$resultprompt$result" |
|
} else { |
|
#if {[string index $result end] eq "\n"} { |
|
# set result [string range $result 0 end-1] |
|
#} |
|
if {[string length $flat] == 0} { |
|
if {[string range $result end-1 end] eq "\r\n"} { |
|
set result [string range $result 0 end-2] |
|
} else { |
|
set result [string range $result 0 end-1] |
|
} |
|
} |
|
#NOTE - textblock::height is the line height - not reflective of height of data with ansi-moves or things like sixels |
|
set h [textblock::height $result] |
|
set promptcol [string repeat $resultprompt\n $h] |
|
set promptcol [string range $promptcol 0 end-1] |
|
rputs [textblock::join -- $promptcol $result] |
|
|
|
#orig |
|
#rputs $resultprompt[string map [list \r\n "\n$resultprompt" \n "\n$resultprompt"] $result] |
|
} |
|
} |
|
doprompt "P% " |
|
} else { |
|
#tcl err |
|
if {$result_is_chunk_list} { |
|
foreach c $last_run_display { |
|
lassign $c termchan text |
|
if {[string length $text]} { |
|
switch -- $termchan { |
|
result { |
|
rputs stdout $resultprompt[string map [list \n "\n$resultprompt"] $text] |
|
#puts -nonewline stdout $text |
|
} |
|
resulterr { |
|
rputs stderr $resultprompt[string map [list \n "\n$resultprompt"] $text] |
|
} |
|
info { |
|
rputs stderr $infoprompt[string map [list \n "\n$infoprompt"] $text] |
|
} |
|
default { |
|
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 { |
|
#doprompt "P% " "green normal" |
|
if {$linenum == 0} { |
|
doprompt "P% " "green normal" |
|
screen_last_char_add " " empty empty |
|
} else { |
|
doprompt "\nP% " "green normal" |
|
screen_last_char_add "\n" empty empty ;#add \n to indicate noclearance required |
|
} |
|
} |
|
#catch {puts stderr "zz1--->[rep $::arglej]"} |
|
#puts stderr "??? $commandstr" |
|
if {$::punk::repl::debug_repl > 0} { |
|
incr ::punk::repl::debug_repl -1 |
|
} |
|
set commandstr "" |
|
#catch {puts stderr "zz2---->[rep $::arglej]"} |
|
|
|
set lines [$editbuf lines] |
|
set buf_has_data 0 |
|
foreach ln $lines { |
|
if {[string trim $ln] ne ""} { |
|
set buf_has_data 1 |
|
} |
|
} |
|
if {$buf_has_data} { |
|
set editbufnext [punk::repl::class::class_editbuf new {}] |
|
lappend editbuf_list $editbufnext |
|
set editbuf_linenum_submitted 0 |
|
set editbuf $editbufnext |
|
} |
|
#editbuf |
|
|
|
} else { |
|
#append commandstr \n |
|
if {$::repl::signal_control_c} { |
|
set ::repl::signal_control_c 0 |
|
fileevent $inputchan readable {} |
|
rputs stderr "* console_control: control-c" |
|
flush stderr |
|
set c [a yellow bold] |
|
set n [a] |
|
rputs stderr "${c}repl interrupted$n" |
|
#set commandstr [list error "repl interrupted"] |
|
set commandstr "" |
|
doprompt ">_ " |
|
flush stdout |
|
|
|
} else { |
|
#Incomplete command |
|
# parse and determine outermost unclosed quote/bracket and include in prompt |
|
if {$linenum == $maxlinenum} { |
|
if {$rawmode} { |
|
#review |
|
#we haven't put the data following last le into commandstr - but we want to display proper completion status prior to enter being hit or more data coming in. |
|
#this could give spurious results for large pastes where buffering chunks it in odd places.? |
|
#it does however give sensible output for the common case of a small paste where the last line ending wasn't included |
|
#set waiting [punk::lib::system::incomplete $commandstr$readingchunk] |
|
set waiting [punk::lib::system::incomplete $commandstr[$editbuf line end]] |
|
} else { |
|
set waiting [punk::lib::system::incomplete $commandstr] |
|
} |
|
if {[llength $waiting]} { |
|
set c [lindex $waiting end] |
|
} else { |
|
#set c " " |
|
set c \u240a |
|
} |
|
doprompt ">$c " |
|
} |
|
} |
|
} |
|
|
|
incr linenum |
|
} |
|
|
|
|
|
if {$maxlinenum == -1} { |
|
#when in raw mode - no linefeed yet received |
|
#rputs stderr "repl: no complete input line: $commandstr" |
|
#screen_last_char_add "\n" empty empty |
|
|
|
#screen_last_char_add [string index $readingchunk end] stdinchunk stdinchunk |
|
screen_last_char_add [string index [$editbuf line end] end] stdinchunk stdinchunk |
|
|
|
} |
|
|
|
|
|
#fileevent $inputchan readable [list repl::repl_handler $inputchan $prompt_config] |
|
#catch {puts stderr "zend--->[rep $::arglej]"} |
|
|
|
|
|
} trap {POSIX} {e eopts} { |
|
rputs stderr "trap POSIX '$e' eopts:'$eopts" |
|
flush stderr |
|
} on error {repl_error erropts} { |
|
rputs stderr "error in repl_handler: $repl_error" |
|
rputs stderr "-------------" |
|
rputs stderr "$::errorInfo" |
|
rputs stderr "-------------" |
|
set stdinreader [fileevent $inputchan readable] |
|
if {![string length $stdinreader]} { |
|
rputs stderr "*> $inputchan reader inactive" |
|
} else { |
|
rputs stderr "*> $inputchan reader active" |
|
} |
|
if {[chan eof $inputchan]} { |
|
rputs stderr "will attempt restart of repl on input channel: $inputchan in next loop" |
|
catch {set ::punk::ns::ns_current "::"} |
|
} else { |
|
rputs stderr "continuing.." |
|
} |
|
flush stderr |
|
#tailcall repl::start $inputchan |
|
|
|
} |
|
} |
|
|
|
proc repl::completion {context ebuf} { |
|
|
|
} |
|
|
|
package provide punk::repl [namespace eval punk::repl { |
|
variable version |
|
set version 0.1 |
|
}] |
|
package provide punk::repl [namespace eval punk::repl { |
|
variable version |
|
set version 0.1 |
|
}] |
|
|
|
#repl::start stdin |
|
#exit 0 |
|
|
|
#repl::start $program_read_stdin_pipe |
|
|
|
|