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.
1111 lines
37 KiB
1111 lines
37 KiB
#temp |
|
package provide app-punk 1.0 |
|
|
|
namespace eval punk { |
|
|
|
} |
|
|
|
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 |
|
} |
|
|
|
|
|
|
|
namespace eval punk { |
|
set syslog_stdout "127.0.0.1:514" |
|
set syslog_stderr "127.0.0.1:514" |
|
|
|
#default file logs to logs folder at same location as exe if writable, or empty string |
|
set logfile_stdout "" |
|
set logfile_stderr "" |
|
set exefolder [file dirname [info nameofexecutable]] |
|
set logfolder $exefolder/logs |
|
if {[file exists $logfolder]} { |
|
if {[file isdirectory $logfolder] && [file writable $logfolder]} { |
|
set logfile_stdout $logfolder/repl-exec-stdout.txt |
|
set logfile_stderr $logfolder/repl-exec-stderr.txt |
|
} |
|
} |
|
|
|
|
|
#override with env vars if set |
|
if {[info exists ::env(PUNK_LOGFILE_STDOUT)]} { |
|
set f $::env(PUNK_LOGFILE_STDOUT) |
|
if {$f ne "default"} { |
|
set logfile_stdout $f |
|
} |
|
} |
|
if {[info exists ::env(PUNK_LOGFILE_STDERR)]} { |
|
set f $::env(PUNK_LOGFILE_STDERR) |
|
if {$f ne "default"} { |
|
set logfile_stderr $f |
|
} |
|
} |
|
if {[info exists ::env(PUNK_SYSLOG_STDOUT)]} { |
|
set u $::env(PUNK_SYSLOG_STDOUT) |
|
if {$u ne "default"} { |
|
set syslog_stdout $u |
|
} |
|
} |
|
if {[info exists ::env(PUNK_SYSLOG_STDERR)]} { |
|
set u $::env(PUNK_SYSLOG_STDERR) |
|
if {$u ne "default"} { |
|
set syslog_stderr $u |
|
} |
|
} |
|
catch { |
|
unset u |
|
unset f |
|
} |
|
|
|
#useful for aliases e.g treemore -> xmore tree |
|
proc xmore {args} { |
|
{*}$args | more |
|
} |
|
proc winpath {path} { |
|
#convert /c/etc to C:/etc |
|
set re {^/([[:alpha:]]){1}/.*} |
|
|
|
set volumes [file volumes] |
|
#exclude things like //zipfs:/ |
|
set driveletters [list] |
|
foreach v $volumes { |
|
if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} { |
|
lappend driveletters $letter |
|
} |
|
} |
|
#puts stderr "->$driveletters" |
|
if {[regexp $re $path _ letter]} { |
|
#upper case appears to be windows canonical form |
|
if {[string toupper $letter] in $driveletters} { |
|
set path [string toupper $letter]:/[string range $path 3 end] |
|
} |
|
} elseif {[regexp {^/mnt|MNT/([[:alpha:]]){1}/.*} $path _ letter]} { |
|
if {[string toupper $letter] in $driveletters} { |
|
set path [string toupper $letter]:/[string range $path 7 end] |
|
} |
|
} |
|
#puts stderr "=> $path" |
|
#things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder |
|
if {![file exists [file dirname $path]]} { |
|
set path [file normalize $path] |
|
} |
|
return $path |
|
} |
|
proc windir {path} { |
|
return [file dirname [punk::winpath $path]] |
|
} |
|
|
|
|
|
namespace export help aliases alias cdwin cdwindir winpath windir |
|
namespace ensemble create |
|
|
|
|
|
proc cdwin {path} { |
|
set path [punk::winpath $path] |
|
cd $path |
|
} |
|
proc cdwindir {path} { |
|
set path [punk::winpath $path] |
|
cd [file dirname $path] |
|
} |
|
proc help {} { |
|
catch { |
|
package require patternpunk |
|
puts -nonewline stderr [>punk . rhs] |
|
} |
|
puts stdout "Punk commands:" |
|
puts stdout "punk help" |
|
} |
|
#current interp aliases except those created by pattern package '::p::*' |
|
proc aliases {{glob *}} { |
|
set interesting [lmap a [interp aliases ""] {expr {![string match ::p::* $a] ? $a : [continue]}}] |
|
} |
|
proc alias {a args} { |
|
if {[llength $args]} { |
|
if {$a in [interp aliases ""]} { |
|
set existing [interp alias "" $a] |
|
puts stderr "Overwriting existing alias $a -> $existing with $a -> $args (in current session only)" |
|
} |
|
interp alias "" $a "" {*}$args |
|
} else { |
|
return [interp alias "" $a] |
|
} |
|
} |
|
|
|
|
|
#global aliases - keep to a minimum |
|
interp alias {} help {} punk help |
|
interp alias {} aliases {} punk aliases |
|
interp alias {} alias {} punk alias |
|
interp alias {} treemore {} punk::xmore tree |
|
#---------------------------------------------- |
|
#leave the winpath related aliases available on all platforms |
|
interp alias {} cdwin {} punk cdwin |
|
interp alias {} cdwindir {} punk cdwindir |
|
interp alias {} winpath {} punk winpath |
|
interp alias {} windir {} punk windir |
|
#---------------------------------------------- |
|
interp alias {} ll {} ls -laFo --color=always |
|
interp alias {} lw {} ls -aFv --color=always |
|
if {$::tcl_platform(platform) eq "windows"} { |
|
set has_powershell 1 |
|
interp alias {} dl {} dir /q |
|
interp alias {} dw {} dir /W/D |
|
} else { |
|
#todo - natsorted equivalent |
|
#interp alias {} dl {} |
|
#todo - powershell detection on other platforms |
|
set has_powershell 0 |
|
} |
|
if {$has_powershell} { |
|
interp alias {} psls {} pwsh -nop -nolo -c ls |
|
interp alias {} psps {} pwsh -nop -nolo -c ps |
|
} |
|
|
|
} |
|
|
|
|
|
|
|
set ::punk::PUNKRUN 0 ;#whether to use shellfilter::run instead of exec. |
|
|
|
package require shellfilter |
|
package require Thread |
|
|
|
set outdevice [shellfilter::stack::new punkout -settings [list -tag "punkout" -buffering none -raw 1 -syslog $::punk::syslog_stdout -file $::punk::logfile_stdout]] |
|
set out [dict get $outdevice localchan] |
|
set errdevice [shellfilter::stack::new punkerr -settings [list -tag "punkerr" -buffering none -raw 1 -syslog $::punk::syslog_stderr -file $::punk::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 { |
|
set id_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] |
|
|
|
if {$::punk::PUNKRUN} { |
|
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] |
|
} |
|
|
|
|
|
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 |
|
} |
|
|
|
|
|
#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 |
|
} |
|
|
|
#NOTE: the run,runout,runerr,runx commands only produce an error if the command didn't run. |
|
# - If it did run, but there was a non-zero exitcode it is up to the application to check that. |
|
#This is deliberate, but means 'catch' doesn't catch errors within the command itself - the exitcode has to be checked. |
|
#The user can always use exec for different process error semantics (they don't get exitcode with exec) |
|
know {[lindex $args 0] eq "runraw"} { |
|
return [do_run $args] |
|
} |
|
know {[lindex $args 0] eq "run"} { |
|
set args [lrange $args 1 end] |
|
set known_runopts [list "-echo" "-e"] |
|
set aliases [list "-e" "-echo" "-echo" "-echo"] ;#include map to self |
|
set runopts [list] |
|
set cmdargs [list] |
|
set idx_first_cmdarg [lsearch -not $args "-*"] |
|
set runopts [lrange $args 0 $idx_first_cmdarg-1] |
|
set cmdargs [lrange $args $idx_first_cmdarg end] |
|
foreach o $runopts { |
|
if {$o ni $known_runopts} { |
|
error "run: Unknown runoption $o" |
|
} |
|
} |
|
set runopts [lmap o $runopts {dict get $aliases $o}] |
|
|
|
set id_err [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] |
|
set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none ] |
|
shellfilter::stack::remove stderr $id_err |
|
|
|
flush stderr |
|
flush stdout |
|
|
|
set c [shellfilter::ansi::+ green] |
|
set n [shellfilter::ansi::+] |
|
if {[dict exists $exitinfo error]} { |
|
error [dict get $exitinfo error] |
|
} |
|
|
|
return $exitinfo |
|
} |
|
|
|
know {[lindex $args 0] eq "runout"} { |
|
set ::runout "" |
|
|
|
set args [lrange $args 1 end] |
|
set known_runopts [list "-echo" "-e"] |
|
set aliases [list "-e" "-echo" "-echo" "-echo"] ;#include map to self |
|
set runopts [list] |
|
set cmdargs [list] |
|
set idx_first_cmdarg [lsearch -not $args "-*"] |
|
set runopts [lrange $args 0 $idx_first_cmdarg-1] |
|
set cmdargs [lrange $args $idx_first_cmdarg end] |
|
foreach o $runopts { |
|
if {$o ni $known_runopts} { |
|
error "runout: Unknown runoption $o" |
|
} |
|
} |
|
set runopts [lmap o $runopts {dict get $aliases $o}] |
|
|
|
#puts stdout "RUNOUT cmdargs: $cmdargs" |
|
|
|
#set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}] |
|
if {"-echo" in $runopts} { |
|
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action sink-locked -settings {-varname ::runout}] |
|
} else { |
|
set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::runout}] |
|
} |
|
|
|
#shellfilter::run [lrange $args 1 end] -teehandle punk -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler |
|
set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none ] |
|
|
|
shellfilter::stack::remove stdout $stdout_stackid |
|
#shellfilter::stack::remove commandout $outvar_stackid |
|
if {[dict exists $exitinfo error]} { |
|
#we must raise an error. |
|
#todo - check errorInfo makes sense.. return -code? tailcall? |
|
error [dict get $exitinfo error] |
|
} |
|
|
|
flush stderr |
|
flush stdout |
|
|
|
set lastoutchar [string range $::repl::output_stdout end-1 end] |
|
|
|
|
|
#exitcode not part of return value - colourcode appropriately |
|
set n [shellfilter::ansi::+] |
|
set code [dict get $exitinfo exitcode] |
|
if {$code == 0} { |
|
set c [shellfilter::ansi::+ green] |
|
} else { |
|
set c [shellfilter::ansi::+ white bold] |
|
} |
|
puts stderr $c$exitinfo$n |
|
return $::runout |
|
} |
|
know {[lindex $args 0] eq "runerr"} { |
|
set ::runerr "" |
|
|
|
set args [lrange $args 1 end] |
|
set known_runopts [list "-echo" "-e"] |
|
set aliases [list "-e" "-echo" "-echo" "-echo"] ;#include map to self |
|
set runopts [list] |
|
set cmdargs [list] |
|
set idx_first_cmdarg [lsearch -not $args "-*"] |
|
set runopts [lrange $args 0 $idx_first_cmdarg-1] |
|
set cmdargs [lrange $args $idx_first_cmdarg end] |
|
foreach o $runopts { |
|
if {$o ni $known_runopts} { |
|
error "runerr: Unknown runoption $o" |
|
} |
|
} |
|
set runopts [lmap o $runopts {dict get $aliases $o}] |
|
|
|
if {"-echo" in $runopts} { |
|
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::runerr}] |
|
} else { |
|
set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::runerr}] |
|
} |
|
set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
|
shellfilter::stack::remove stderr $stderr_stackid |
|
|
|
|
|
flush stderr |
|
flush stdout |
|
|
|
#we raise an error because an error during calling is different to collecting stderr from a command, and the caller should be able to wrap in a catch |
|
# to determine something other than just a nonzero exit code or output on stderr. |
|
if {[dict exists $exitinfo error]} { |
|
#todo - check errorInfo makes sense.. return -code? tailcall? |
|
error [dict get $exitinfo error] |
|
} |
|
|
|
#exitcode not part of return value - colourcode appropriately |
|
set n [shellfilter::ansi::+] |
|
set code [dict get $exitinfo exitcode] |
|
if {$code == 0} { |
|
set c [shellfilter::ansi::+ green] |
|
} else { |
|
set c [shellfilter::ansi::+ white bold] |
|
} |
|
puts stderr \n$c$exitinfo$n |
|
return $::runerr |
|
} |
|
know {[lindex $args 0] eq "runx"} { |
|
set ::runerr "" |
|
set ::runout "" |
|
|
|
set args [lrange $args 1 end] |
|
set known_runopts [list "-echo" "-e"] |
|
set aliases [list "-e" "-echo" "-echo" "-echo"] ;#include map to self |
|
set runopts [list] |
|
set cmdargs [list] |
|
set idx_first_cmdarg [lsearch -not $args "-*"] |
|
set runopts [lrange $args 0 $idx_first_cmdarg-1] |
|
set cmdargs [lrange $args $idx_first_cmdarg end] |
|
foreach o $runopts { |
|
if {$o ni $known_runopts} { |
|
error "runx: Unknown runoption $o" |
|
} |
|
} |
|
set runopts [lmap o $runopts {dict get $aliases $o}] |
|
|
|
|
|
|
|
#shellfilter::stack::remove stdout $::repl::id_outstack |
|
|
|
if {"-echo" in $runopts} { |
|
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::runerr}] |
|
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action sink-locked -settings {-varname ::runout}] |
|
} else { |
|
set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::runerr}] |
|
set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::runout}] |
|
} |
|
|
|
set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
|
|
|
shellfilter::stack::remove stdout $stdout_stackid |
|
shellfilter::stack::remove stderr $stderr_stackid |
|
|
|
set ::repl::output "" |
|
|
|
flush stderr |
|
flush stdout |
|
|
|
#set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] |
|
set pretty "" |
|
append pretty "stdout\n" |
|
if {[string length $::runout]} { |
|
append pretty "$::runout\n" |
|
} |
|
append pretty "stderr\n" |
|
if {[string length $::runerr]} { |
|
append pretty "$::runerr\n" |
|
} |
|
set n [shellfilter::ansi::+] |
|
set c "" |
|
if [dict exists $exitinfo exitcode] { |
|
set code [dict get $exitinfo exitcode] |
|
if {$code == 0} { |
|
set c [shellfilter::ansi::+ green] |
|
} else { |
|
set c [shellfilter::ansi::+ white bold] |
|
} |
|
} |
|
append pretty "$c$exitinfo$n" |
|
#set ::repl::result_print 0 |
|
#return [lindex [list [list stdout $::runout stderr $::runerr {*}$exitinfo] [shellfilter::stack::remove stdout $x][puts -nonewline stdout $pretty][set ::repl::output ""]] 0] |
|
|
|
set ::repl::result_pretty $pretty |
|
|
|
if {[dict exists $exitinfo error]} { |
|
#todo - check errorInfo makes sense.. return -code? tailcall? |
|
error [dict get $exitinfo error] |
|
} |
|
|
|
|
|
return [list stdout $::runout stderr $::runerr {*}$exitinfo] |
|
|
|
|
|
#return [string map [list %o% [list $::runout] %e% [list $::runerr] %x% $exitinfo] {stdout\ |
|
# %o%\ |
|
# stderr\ |
|
# %e%\ |
|
# %x%\ |
|
#}] |
|
} |
|
} |
|
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" |
|
} |
|
#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 |
|
variable result_print |
|
variable result_pretty |
|
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 errstack [list] |
|
set id_outstack [shellfilter::stack::add stdout tee_to_var -settings {-varname ::repl::output_stdout}] |
|
lappend errstack [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] |
|
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 |
|
set result_print 1 |
|
set result_pretty "" |
|
#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] |
|
} |
|
|
|
#puts stderr "<output>'$::repl::output_stdout' lastoutchar:'$lastoutchar' result:'$result'" |
|
flush stdout |
|
shellfilter::stack::remove stdout $id_outstack |
|
flush stderr |
|
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] |
|
if {!$result_print} { |
|
set result "" |
|
set lastoutchar "" |
|
set lasterrchar "" |
|
} |
|
#$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 test [string trim $command] |
|
if {[string equal -length [string length "runx "] "runx " $command]} { |
|
if {[string length $result_pretty]} { |
|
set result $result_pretty |
|
} |
|
} |
|
fileevent $chan readable [list [namespace current]::repl_handler $chan] |
|
set reading 1 |
|
if {$result ne ""} { |
|
if {$status == 0} { |
|
if {[string length $lastoutchar$lasterrchar]} { |
|
puts \n$result |
|
} 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 |
|
|
|
|