#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