#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 !!, !, 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 "'$::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