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.
781 lines
27 KiB
781 lines
27 KiB
#temp |
|
package provide app-punk 1.0 |
|
|
|
namespace eval punkrepl { |
|
|
|
} |
|
|
|
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" |
|
|
|
|
|
} |
|
tcl::tm::add [pwd]/modules |
|
|
|
if {![info exists ::env(SHELL)]} { |
|
set ::env(SHELL) punk86 |
|
} |
|
if {![info exists ::env(TERM)]} { |
|
#fake it |
|
#set ::env(TERM) vt100 |
|
set ::env(TERM) xterm-256color |
|
} |
|
|
|
|
|
|
|
package require shellfilter |
|
package require shellrun |
|
package require Thread |
|
package require punk |
|
|
|
|
|
|
|
|
|
|
|
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 { |
|
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 { |
|
|
|
#when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks |
|
set id_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] |
|
|
|
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 redir ">&@stdout <@stdin" |
|
uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] |
|
#we can't detect stdout/stderr output from the exec |
|
#for now emit an extra \n on stderr |
|
#todo - use console apis (twapi on windows) to detect cursor posn? |
|
puts -nonewline stderr \n[a+ green bold]-[a+] |
|
} |
|
|
|
|
|
shellfilter::stack::remove stderr $id_stderr |
|
} |
|
|
|
|
|
#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 |
|
} |
|
} |
|
} |
|
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]" |
|
} |
|
} |
|
return -code error -errorcode [list TCL LOOKUP COMMAND $name] \ |
|
"invalid command name \"$name\"" |
|
} |
|
|
|
|
|
proc know {cond body} { |
|
proc unknown {args} [string map [list @c@ $cond @b@ $body] { |
|
if {![catch {expr {@c@}} res] && $res} { |
|
return [eval {@b@}] |
|
#tailcall @b@ |
|
} |
|
}][info body unknown] |
|
} |
|
proc know? {} { |
|
puts [string range [info body unknown] 0 511] |
|
} |
|
if 1 { |
|
know {[expr $args] || 1} {expr $args} |
|
know {[regexp {^([0-9]+)\.\.([0-9]+)$} [lindex $args 0] -> from to]} { |
|
set res {} |
|
while {$from<=$to} {lappend res $from; incr from} |
|
set res |
|
} |
|
|
|
#handle process return dict of form {exitcode num etc blah} |
|
#ie when the return result as a whole is treated as a command |
|
#exitcode must be the first key |
|
know {[lindex $args 0 0] eq "exitcode"} { |
|
#set c [lindex $args 0 1] |
|
uplevel 1 [list exitcode {*}[lrange [lindex $args 0] 1 end]] |
|
} |
|
|
|
|
|
#run as raw string instead of tcl-list - no variable subst etc |
|
proc do_runraw {commandline} { |
|
#return [shellfilter::run [lrange $args 1 end] -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
|
puts stdout ">>runraw got: $commandline" |
|
|
|
#run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing |
|
#for consistency with other runxxx commands - we'll just consume it. (review) |
|
#set wordparts [regexp -inline -all {\S+} $commandline] |
|
package require string::token::shell |
|
set parts [string token shell -indices $commandline] |
|
puts stdout ">>shellparts: $parts" |
|
|
|
set runwords [list] |
|
foreach p $parts { |
|
set ptype [lindex $p 0] |
|
set pval [lindex $p 3] |
|
if {$ptype eq "PLAIN"} { |
|
lappend runwords [lindex $p 3] |
|
} elseif {$ptype eq "D:QUOTED"} { |
|
set v {"} |
|
append v $pval |
|
append v {"} |
|
lappend runwords $v |
|
} elseif {$ptype eq "S:QUOTED"} { |
|
set v {'} |
|
append v $pval |
|
append v {'} |
|
lappend runwords $v |
|
} |
|
} |
|
puts stdout ">>runraw runwords: $runwords" |
|
set runwords [lrange $runwords 1 end] |
|
|
|
puts stdout ">>runraw runwords: $runwords" |
|
#set args [lrange $args 1 end] |
|
#set runwords [lrange $wordparts 1 end] |
|
|
|
set known_runopts [list "-echo" "-e" "-terminal" "-t"] |
|
set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self |
|
set runopts [list] |
|
set cmdwords [list] |
|
set idx_first_cmdarg [lsearch -not $runwords "-*"] |
|
set runopts [lrange $runwords 0 $idx_first_cmdarg-1] |
|
set cmdwords [lrange $runwords $idx_first_cmdarg end] |
|
|
|
foreach o $runopts { |
|
if {$o ni $known_runopts} { |
|
error "runraw: Unknown runoption $o" |
|
} |
|
} |
|
set runopts [lmap o $runopts {dict get $aliases $o}] |
|
|
|
set cmd_as_string [join $cmdwords " "] |
|
puts stdout ">>cmd_as_string: $cmd_as_string" |
|
|
|
if {"-terminal" in $runopts} { |
|
set tcmd [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdwords] |
|
puts stdout ">>tcmd: $tcmd" |
|
#set exitinfo [shellfilter::run $tcmd -teehandle punk -inbuffering line -outbuffering none ] |
|
set exitinfo "exitcode not-implemented" |
|
} else { |
|
set exitinfo [shellfilter::run $cmdwords -teehandle punk -inbuffering line -outbuffering none ] |
|
} |
|
|
|
if {[dict exists $exitinfo error]} { |
|
#todo - check errorInfo makes sense.. return -code? tailcall? |
|
error [dict get $exitinfo error] |
|
} |
|
set code [dict get $exitinfo exitcode] |
|
if {$code == 0} { |
|
set c [shellfilter::ansi::+ green] |
|
} else { |
|
set c [shellfilter::ansi::+ white bold] |
|
} |
|
puts stderr $c |
|
return $exitinfo |
|
} |
|
|
|
know {[lindex $args 0] eq "runraw"} { |
|
return [do_runraw $args] |
|
} |
|
|
|
} |
|
namespace eval repl { |
|
variable output "" |
|
#important not to initialize - as it can be preset by cooperating package before app-punk has been package required |
|
variable post_script |
|
} |
|
|
|
|
|
proc repl::doprompt {prompt {col {green bold}}} { |
|
#prompt to stderr. |
|
#We can pipe commands into repl's stdin without the prompt interfering with the output. |
|
#Although all command output for each line goes to stdout - not just what is emmited with puts |
|
if {$::tcl_interactive} { |
|
set o [shellfilter::ansi::+ {*}$col] |
|
set r [shellfilter::ansi::+] |
|
puts -nonewline stderr $o$prompt$r |
|
flush stderr |
|
} |
|
} |
|
|
|
proc repl::start {inchan} { |
|
variable command |
|
variable running |
|
variable reading |
|
variable done |
|
set running 1 |
|
set command "" |
|
doprompt "P% " |
|
fileevent $inchan readable [list [namespace current]::repl_handler $inchan] |
|
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 |
|
|
|
} |
|
proc repl::repl_handler {chan} { |
|
variable command |
|
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 $chan line] |
|
if {$chunksize < 0} { |
|
if {[chan eof $chan]} { |
|
fileevent $chan readable {} |
|
set reading 0 |
|
set running 0 |
|
if {$::tcl_interactive} { |
|
puts stderr "\n|repl> EOF on $chan." |
|
} |
|
set [namespace current]::done 1 |
|
#test |
|
repl::reopen_stdin |
|
return |
|
} |
|
} |
|
append command $line |
|
if {[info complete $command]} { |
|
set ::repl::output_stdout "" |
|
set ::repl::output_stderr "" |
|
set outstack [list] |
|
set errstack [list] |
|
if {[string length [dict get $running_config color_stdout]]} { |
|
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]]} { |
|
lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]] |
|
} |
|
|
|
lappend errstack [shellfilter::stack::add stderr tee_to_var -settings {-varname ::repl::output_stderr}] |
|
#chan configure stdout -buffering none |
|
fileevent $chan readable {} |
|
set reading 0 |
|
#don't let unknown use 'args' to convert command to list |
|
|
|
if {[string equal -length [string length "runraw "] "runraw " $command]} { |
|
set status [catch {uplevel #0 [list do_runraw $command]} result] |
|
} else { |
|
#puts stderr "repl uplevel 0 '$command'" |
|
set status [catch {uplevel #0 $command} result] |
|
} |
|
|
|
flush stdout |
|
flush stderr |
|
|
|
foreach s [lreverse $outstack] { |
|
shellfilter::stack::remove stdout $s |
|
} |
|
foreach s [lreverse $errstack] { |
|
shellfilter::stack::remove stderr $s |
|
} |
|
set lastoutchar [string range $::repl::output_stdout end-1 end] |
|
set lasterrchar [string range $::repl::output_stderr end-1 end] |
|
|
|
set ::repl::last_stdout $::repl::output_stdout |
|
set ::repl::last_stderr $::repl::output_stderr |
|
|
|
#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"} {} |
|
|
|
set result_is_chunk_list 0 |
|
set test [string trim $command] |
|
if { |
|
[string equal -length [string length "./ "] "./ " $command] || \ |
|
[string equal "./" $command] || \ |
|
[string equal -length [string length "../ "] "../ " $command] || \ |
|
[string equal "../" $command] || \ |
|
[string equal -length [string length "runx "] "runx " $command] || \ |
|
[string equal -length [string length "runout "] "runout " $command] || \ |
|
[string equal -length [string length "runerr "] "runerr " $command] |
|
|
|
} { |
|
if {[llength $last_run_display]} { |
|
set result $last_run_display |
|
set result_is_chunk_list 1 |
|
} |
|
} |
|
fileevent $chan readable [list [namespace current]::repl_handler $chan] |
|
set reading 1 |
|
if {$result ne ""} { |
|
if {$status == 0} { |
|
if {[string length $lastoutchar$lasterrchar]} { |
|
puts -nonewline stderr \n |
|
} |
|
if {$result_is_chunk_list} { |
|
foreach c $result { |
|
lassign $c chan text |
|
if {[string length $text]} { |
|
puts -nonewline $chan $text |
|
} |
|
} |
|
|
|
} else { |
|
puts $result |
|
} |
|
doprompt "P% " |
|
} else { |
|
#tcl err |
|
set c [shellfilter::ansi::+ yellow bold] |
|
set n [shellfilter::ansi::+] |
|
puts stderr $c$result$n |
|
#tcl err hint prompt - lowercase |
|
doprompt "p% " |
|
} |
|
} else { |
|
if {[string length $lastoutchar$lasterrchar]} { |
|
doprompt "\nP% " |
|
} else { |
|
doprompt "P% " |
|
} |
|
} |
|
set command "" |
|
} else { |
|
append command \n |
|
doprompt "> " |
|
} |
|
} |
|
repl::start stdin |
|
|
|
exit 0 |
|
|
|
#repl::start $program_read_stdin_pipe |
|
|
|
|