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.
1204 lines
44 KiB
1204 lines
44 KiB
#temp |
|
package provide app-punk 1.0 |
|
|
|
namespace eval punkrepl { |
|
|
|
} |
|
|
|
#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" |
|
|
|
} |
|
|
|
if {[string match "*.vfs/*" [info script]]} { |
|
#src/xxx.vfs/lib/app-punk/repl.tcl |
|
#back 5 gives same level as src folder |
|
#we assume if calling directly into .vfs that the user would prefer to use src/modules - so back only 4 |
|
set modulefolder [file dirname [file dirname [file dirname [file dirname [info script]]]]]/modules |
|
|
|
} else { |
|
set modulefolder [file dirname [info nameofexecutable]]/modules |
|
} |
|
|
|
if {[file exists $modulefolder]} { |
|
tcl::tm::add $modulefolder |
|
} else { |
|
puts stderr "Warning unable to find module folder at: $modulefolder" |
|
} |
|
|
|
|
|
if {[file exists [pwd]/modules]} { |
|
tcl::tm::add [pwd]/modules |
|
} |
|
|
|
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 |
|
#} |
|
} |
|
|
|
|
|
package require Thread |
|
#These are strong dependencies |
|
# - the repl requires Threading and punk,shellfilter,shellrun to call and display properly. |
|
# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list |
|
|
|
package forget shellfilter |
|
package require shellfilter |
|
package forget shellrun |
|
package require shellrun |
|
package forget punk |
|
package require punk |
|
|
|
|
|
|
|
|
|
#todo - move to less generic namespace |
|
namespace eval repl { |
|
variable screen_last_chars "" ;#a small sliding append buffer for last char of any screen output to detect \n vs string |
|
variable screen_last_char_list [list] |
|
|
|
variable last_unknown "" |
|
variable prompt_reset_flag 0 ;#trigger repl to re-retrieve prompt settings |
|
variable output "" |
|
#important not to initialize - as it can be preset by cooperating package before app-punk has been package required |
|
variable post_script |
|
variable signal_control_c 0 |
|
} |
|
|
|
namespace eval punkrepl { |
|
variable debug_repl 0 |
|
|
|
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" $rep1] |
|
|
|
#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::term { |
|
} |
|
|
|
package require term::ansi::code::ctrl |
|
if {$::tcl_platform(platform) eq "windows"} { |
|
package require twapi |
|
proc ::repl::term::handler_console_control {args} { |
|
set ::repl::signal_control_c 1 |
|
#rputs stderr "* console_control: $args" |
|
#return 0 to fall through to default handler |
|
return 1 |
|
} |
|
twapi::set_console_control_handler ::repl::term::handler_console_control |
|
proc ::repl::term::set_console_title {text} { |
|
#twapi::set_console_title $text |
|
puts -nonewline [term::ansi::code::ctrl::title $text] |
|
} |
|
proc ::repl::term::set_console_icon {name} { |
|
#todo |
|
} |
|
} else { |
|
#TODO |
|
proc ::repl::term::set_console_title {text} { |
|
#todo - terminfo/termcap? |
|
#puts -nonewline "\033\]2;$text\007" ;#works for xterm and most derivatives |
|
puts -nonewline [term::ansi::code::ctrl::title $text] |
|
} |
|
proc ::repl::term::set_console_icon {name} { |
|
#old xterm feature for label given to xterm window when miniaturized? TODO research |
|
#puts -nonewline "\033\]1;$name\007" |
|
} |
|
} |
|
|
|
|
|
#expermental terminal alt screens |
|
proc ::repl::term::screen_push_alt {} { |
|
#tput smcup |
|
puts -nonewline stderr "\033\[?1049h" |
|
} |
|
proc ::repl::term::screen_pop_alt {} { |
|
#tput rmcup |
|
puts -nonewline stderr "\033\[?1049l" |
|
} |
|
interp alias {} smcup {} ::repl::term::screen_push_alt |
|
interp alias {} rmcup {} ::repl::term::screen_pop_alt |
|
|
|
|
|
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. |
|
|
|
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" |
|
|
|
#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::doprompt {prompt {col {green bold}}} { |
|
#prompt to stderr. |
|
#We can pipe commands into repl's stdin without the prompt interfering with the output. |
|
#Although all command output for each line goes to stdout - not just what is emmited with puts |
|
if {$::tcl_interactive} { |
|
set o [a+ {*}$col] |
|
set r [a+] |
|
puts -nonewline stderr $o$prompt$r |
|
flush stderr |
|
} |
|
} |
|
proc repl::get_prompt_config {} { |
|
if {$::tcl_interactive} { |
|
#todo make a+ stacking |
|
set resultprompt "[a+ green bold]-[a+] " |
|
set infoprompt "[a+ green bold]*[a+] " |
|
set debugprompt "[a+ purple bold]~[a+] " |
|
} else { |
|
set resultprompt "" |
|
set infoprompt "" |
|
set debugprompt "" |
|
} |
|
return [list resultprompt $resultprompt infoprompt $infoprompt debugprompt $debugprompt] |
|
} |
|
proc repl::start {inchan} { |
|
variable commandstr |
|
variable running |
|
variable reading |
|
variable done |
|
set running 1 |
|
set commandstr "" |
|
set prompt_config [get_prompt_config] |
|
doprompt "P% " |
|
fileevent $inchan readable [list [namespace current]::repl_handler $inchan $prompt_config] |
|
set reading 1 |
|
vwait [namespace current]::done |
|
#todo - override exit? |
|
after 0 ::repl::post_operations |
|
vwait repl::post_operations_done |
|
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 {} { |
|
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 |
|
chan close stdin |
|
if {$::tcl_platform(platform) eq "windows"} { |
|
set s [open "CON" r] |
|
} 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 10 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] |
|
} |
|
proc repl::screen_last_char_get {} { |
|
variable screen_last_char_list |
|
return [lindex $screen_last_char_list end 0] |
|
} |
|
proc repl::screen_last_char_getinfo {} { |
|
variable screen_last_char_list |
|
return [lindex $screen_last_char_list end] |
|
} |
|
|
|
#-------------------------------------- |
|
#another experiment |
|
proc repl::newout {} { |
|
namespace eval ::replout { |
|
namespace ensemble create -map { |
|
initialize init |
|
finalize close |
|
watch watch |
|
write write |
|
} |
|
} |
|
proc ::replout::init {id mode} { |
|
return {initialize finalize watch write} |
|
} |
|
proc ::replout::close {id} { |
|
|
|
} |
|
proc ::replout::watch {id spec} { |
|
|
|
} |
|
proc ::replout::write {id data} { |
|
puts -nonewline stderr $data |
|
return [string length $data] |
|
} |
|
|
|
close stdout |
|
set fd [chan create write ::replout] |
|
chan configure $fd -buffering none |
|
return $fd |
|
} |
|
interp alias {} newout {} repl::newout |
|
proc repl::newout2 {} { |
|
close stdout |
|
set s [open "CON" w] |
|
chan configure $s -buffering none |
|
} |
|
#-------------------------------------- |
|
|
|
#use rputs in repl_handler instead of puts |
|
# - to help ensure we don't emit extra blank lines in info or debug output |
|
#rputs expects the standard tcl 'puts' command to be in place. |
|
# all bets are off if this has been redefined with some other api |
|
# rputs deliberately doesn't check screen_last_chars before emitting data (unless reporting an error in rputs itself) |
|
proc repl::rputs {args} { |
|
variable screen_last_chars |
|
variable last_out_was_newline |
|
variable last_repl_char |
|
|
|
if {[::tcl::mathop::<= 1 [llength $args] 3]} { |
|
set out [lindex $args end] |
|
if {([llength $args] > 1) && [lindex $args 0] ne "-nonewline"} { |
|
set this_tail \n |
|
set rputschan [lindex $args 0] |
|
} elseif {[llength $args] == 1} { |
|
set this_tail \n |
|
set rputschan "stdout" |
|
} else { |
|
#>1 arg with -nonewline |
|
set this_tail [string index $out end] |
|
set rputschan [lindex $args 1] |
|
} |
|
set last_char_info_width 40 |
|
set summary "[::shellfilter::ansi::stripcodes [string range $out 0 $last_char_info_width]]" |
|
if {[string length $out] > $last_char_info_width} { |
|
append summary " ..." |
|
} |
|
screen_last_char_add $this_tail repl-$rputschan" $summary |
|
#tailcall? |
|
puts {*}$args |
|
} else { |
|
#looks like an invalid puts call - use the normal error produced by the puts command |
|
#This should only occur if the repl itself is being rewritten/debugged, |
|
#so we will use red "!" and not worry about the extra newlines before and after |
|
if {[catch { puts {*}$args } err]} { |
|
set c [a+ yellow bold] |
|
set n [a+] |
|
#possibly non punk-compliant output because we're assuming the repl was the most recent emitter |
|
#could be wrong, in which case we may emit an extra newline |
|
#- shouldn't matter in this case |
|
#set last_char [string range $screen_last_chars end] |
|
set last_char [screen_last_char_get] |
|
if {$last_char eq "\n"} { |
|
set clear "" |
|
} else { |
|
set clear "\n" |
|
} |
|
puts -nonewline stderr "$clear[a+ red bold]! REPL ERROR IN rputs $c$err$n\n" |
|
screen_last_char_add "\n" replerror "rputs err: '$err'" |
|
return |
|
} else { |
|
#?? shouldn't happen with standard puts command |
|
#do our best and assume final arg is still the data being emitted |
|
#worst that will happen is we won't detect a trailing newline and will later emit an extra blank line. |
|
set out [lindex $args end] |
|
set this_tail [string index $out end] |
|
screen_last_char_add $this_tail replunknown "rputs $args" |
|
return |
|
} |
|
} |
|
} |
|
#whether we need a newline as clearance from previous output |
|
proc repl::screen_needs_clearance {} { |
|
variable screen_last_chars |
|
|
|
#set last_char [string index $screen_last_chars end] |
|
set last_char_info [screen_last_char_getinfo] |
|
if {![llength $last_char_info]} { |
|
#assumption |
|
return 1 |
|
} |
|
lassign $last_char_info c what why |
|
if {$what in [list "stdout" "stderr" "stdout/stderr"]} { |
|
return 1 |
|
} |
|
|
|
|
|
if {$c eq "\n"} { |
|
return 0 |
|
} else { |
|
return 1 |
|
} |
|
} |
|
|
|
proc repl::repl_handler {inputchan prompt_config} { |
|
variable prompt_reset_flag |
|
#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 commandstr |
|
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 chunksize [gets $inputchan line] |
|
if {$chunksize < 0} { |
|
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 |
|
repl::reopen_stdin |
|
return |
|
} |
|
} |
|
set resultprompt [dict get $prompt_config resultprompt] |
|
set infoprompt [dict get $prompt_config infoprompt] |
|
set debugprompt [dict get $prompt_config debugprompt] |
|
|
|
|
|
append commandstr $line\n |
|
#puts "=============>$commandstr" |
|
set ::repl::last_repl_char "\n" ;#this is actually the eol from stdin |
|
screen_last_char_add "\n" stdin $line |
|
if {[info complete $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 {[string is integer -strict $cmd_secondword]} { |
|
incr ::punkrepl::debug_repl $cmd_secondword |
|
} else { |
|
incr ::punkrepl::debug_repl |
|
} |
|
set commandstr "set ::punkrepl::debug_repl" |
|
} |
|
if {$::punkrepl::debug_repl > 0} { |
|
proc debug_repl_emit {msg} [string map [list %p% [list $debugprompt]] { |
|
set p %p% |
|
#don't auto-append \n even if missing. |
|
#we may want to use debug_repl_emit with multiple calls for one output line |
|
#if {[string index $msg end] ne "\n"} { |
|
# set msg "$msg\n" |
|
#} |
|
#set last_char [string index $::repl::screen_last_chars end] |
|
set last_char [screen_last_char_get] |
|
if {$last_char ne "\n"} { |
|
set clearance "\n" |
|
} else { |
|
set clearance "" |
|
} |
|
rputs stderr $clearance$p[string map [list \n \n$p] $msg] |
|
}] |
|
set info "last_run_info\n" |
|
append info "length: [llength $::punk::last_run_display]\n" |
|
debug_repl_emit $info |
|
} else { |
|
proc debug_repl_emit {msg} {return} |
|
} |
|
|
|
#----------------------------------------- |
|
#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::ansi]} { |
|
lappend outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]] |
|
} |
|
lappend outstack [shellfilter::stack::add stdout tee_to_var -settings {-varname ::repl::output_stdout}] |
|
if {[string length [dict get $running_config color_stderr]] && [punk::ansi]} { |
|
lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]] |
|
} |
|
lappend errstack [shellfilter::stack::add stderr tee_to_var -settings {-varname ::repl::output_stderr}] |
|
#chan configure stdout -buffering none |
|
fileevent $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]} result] |
|
} else { |
|
#puts stderr "repl uplevel 0 '$command'" |
|
set status [catch { |
|
#uplevel 1 $run_command_string |
|
uplevel 1 {namespace eval $punk::ns_current $run_command_string} |
|
} 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 punkrepl::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 $::repl::output_stdout end] |
|
set lasterrchar [string index $::repl::output_stderr end] |
|
|
|
#to determine whether cursor is back at col0 of newline |
|
screen_last_char_add [string index $lastoutchar$lasterrchar end] "stdout/stderr" |
|
|
|
set result_is_chunk_list 0 |
|
#------ |
|
#todo - fix. It doesn't make much sense to only detect if the unknown command occurred in first word. |
|
#e.g set x [something arg] not detected vs something arg |
|
#also - unknown commands aren't the only things that can write directly to the os handles stderr & stdout |
|
if { |
|
[string length $::repl::last_unknown] && \ |
|
[string equal -length [string length $::repl::last_unknown] $::repl::last_unknown $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 |
|
set lastcharinfo "\n" |
|
set whatcol [string repeat " " 12] |
|
foreach cinfo $::repl::screen_last_char_list { |
|
lassign $cinfo c whatinfo whyinfo |
|
set cdisplay [string map [list \r "-r-" \n "-n-"] $c] |
|
if {[string length $cdisplay] == 1} { |
|
set cdisplay "$cdisplay " ;#make 3 wide to match -n- and -r- |
|
} |
|
set whatinfo [string range $whatinfo$whatcol 0 [string length $whatcol]] |
|
set whysummary [string map [list \n "-n-"] $whyinfo] |
|
append lastcharinfo "$cdisplay $whatinfo $whysummary\n" |
|
} |
|
debug_repl_emit "screen_last_chars: $lastcharinfo" |
|
debug_repl_emit "lastoutchar:'$lastoutchar' lasterrchar: '$lasterrchar'" |
|
if {$status == 0} { |
|
debug_repl_emit "command call status: $status OK" |
|
} else { |
|
debug_repl_emit "command call status: $status ERR" |
|
} |
|
|
|
|
|
|
|
|
|
#puts stderr "<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 "./ "] "./ " $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 |
|
if {[catch {lrange $result 0 end} result_as_list]} { |
|
set is_result_empty [expr {$result eq ""}] |
|
|
|
} else { |
|
set is_result_empty [expr {[llength $result_as_list] == 0}] |
|
} |
|
|
|
|
|
#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]} { |
|
if {$termchan eq "result"} { |
|
rputs stdout $resultprompt[string map [list \n "\n$resultprompt"] $text] |
|
#puts -nonewline stdout $text |
|
} elseif {$termchan eq "resulterr"} { |
|
rputs stderr $resultprompt[string map [list \n "\n$resultprompt"] $text] |
|
} elseif {$termchan eq "info"} { |
|
rputs stderr $infoprompt[string map [list \n "\n$infoprompt"] $text] |
|
} else { |
|
rputs -nonewline $termchan $text |
|
} |
|
} |
|
} |
|
|
|
} else { |
|
#----------------------------------------------------------- |
|
# 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] |
|
} |
|
#----------------------------------------------------------- |
|
#rputs $resultprompt[string map [list \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]} { |
|
if {$termchan eq "result"} { |
|
rputs stdout $resultprompt[string map [list \n "\n$resultprompt"] $text] |
|
#puts -nonewline stdout $text |
|
} elseif {$termchan eq "resulterr"} { |
|
rputs stderr $resultprompt[string map [list \n "\n$resultprompt"] $text] |
|
} elseif {$termchan eq "info"} { |
|
rputs stderr $infoprompt[string map [list \n "\n$infoprompt"] $text] |
|
} else { |
|
rputs -nonewline $termchan $text |
|
} |
|
} |
|
} |
|
} |
|
|
|
set c [a+ yellow bold] |
|
set n [a+] |
|
rputs stderr $c$result$n |
|
#tcl err hint prompt - lowercase |
|
doprompt "p% " |
|
} |
|
} else { |
|
if {[screen_needs_clearance]} { |
|
doprompt "\nP% " |
|
} else { |
|
doprompt "P% " |
|
} |
|
} |
|
#catch {puts stderr "zz1--->[rep $::arglej]"} |
|
#puts stderr "??? $commandstr" |
|
if {$::punkrepl::debug_repl > 0} { |
|
incr ::punkrepl::debug_repl -1 |
|
} |
|
set commandstr "" |
|
#catch {puts stderr "zz2---->[rep $::arglej]"} |
|
} else { |
|
#append commandstr \n |
|
if {$::repl::signal_control_c} { |
|
set ::repl::signal_control_c 0 |
|
rputs stderr "* console_control: control-c" |
|
set c [a+ yellow bold] |
|
set n [a+] |
|
rputs stderr "${c}repl interrupted$n" |
|
#set commandstr [list error "repl interrupted"] |
|
set commandstr "" |
|
doprompt ">_ " |
|
|
|
} else { |
|
doprompt "> " |
|
} |
|
} |
|
fileevent $inputchan readable [list [namespace current]::repl_handler $inputchan $prompt_config] |
|
#fileevent $inputchan readable [list repl::repl_handler $inputchan $prompt_config] |
|
#catch {puts stderr "zend--->[rep $::arglej]"} |
|
} |
|
#repl::start stdin |
|
#exit 0 |
|
|
|
#repl::start $program_read_stdin_pipe |
|
|
|
|