6 changed files with 1322 additions and 428 deletions
@ -0,0 +1,265 @@ |
|||||||
|
#<?xml version="1.0"?> |
||||||
|
#<xml> |
||||||
|
#<xpack> |
||||||
|
#<code> |
||||||
|
#<![CDATA[ |
||||||
|
# Author: Julian Marcel Noble <julian@cyberclad.com> |
||||||
|
# 2004 - Public Domain |
||||||
|
# |
||||||
|
# PatternPunk - DIALECT |
||||||
|
#Dynamic Instance Accumulation Language Extending Classic Tcl |
||||||
|
#The goofy acronym is a fancy way of not referring to PatternPunk as yet another OO system. |
||||||
|
|
||||||
|
|
||||||
|
package require pattern |
||||||
|
package require overtype |
||||||
|
pattern::init |
||||||
|
|
||||||
|
package provide patternpunk [namespace eval punk { |
||||||
|
variable version |
||||||
|
|
||||||
|
set version 1.1 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
|
::>pattern .. Create ::>punk |
||||||
|
::>punk .. Property license {Public Domain} |
||||||
|
::>punk .. Property logo2 { |
||||||
|
+-----------------------+ |
||||||
|
| Pattern PUNK | |
||||||
|
| . \\\_ . | |
||||||
|
| .*. \@ > .=. | |
||||||
|
| .*.*. | ~ .=.=. | |
||||||
|
|.*.*.*.\_- -_/.=.=.=.| |
||||||
|
| .*.*. \\ .=.=. | |
||||||
|
| .*. / \ .=. | |
||||||
|
| . _+ +_ . | |
||||||
|
+-----------------------+ |
||||||
|
} |
||||||
|
set ::punk::bannerTemplate { |
||||||
|
+-----------------------+ |
||||||
|
| .000000000000000. | |
||||||
|
| .*. \\\_ .=. | |
||||||
|
| .*.*. \@ > .=.=. | |
||||||
|
|.*.*.*. | ~ .=.=.=.| |
||||||
|
| .*.*. \_- -_/ .=.=. | |
||||||
|
| .*. \\ .=. | |
||||||
|
| . / \ . | |
||||||
|
|111111111_+ +_2222222| |
||||||
|
+-----------------------+ |
||||||
|
} |
||||||
|
|
||||||
|
>punk .. Method banner {args} { |
||||||
|
set defaults [list -title "Pattern PUNK" -left "" -right ""] |
||||||
|
if {[catch {set opts [dict merge $defaults $args]} ]} { |
||||||
|
error "usage: banner \[-title \$title -left \$left -right \$right\]" |
||||||
|
} |
||||||
|
|
||||||
|
set word1 [overtype::left [string repeat " " 9] [dict get $opts -left]] |
||||||
|
set word2 [overtype::right [string repeat " " 7] [dict get $opts -right]] |
||||||
|
set title [overtype::centre [string repeat " " 15] [dict get $opts -title]] |
||||||
|
|
||||||
|
return [string map [list 111111111 $word1 2222222 $word2 000000000000000 $title] $punk::bannerTemplate] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
>punk .. Property logo [>punk . banner] |
||||||
|
>punk .. Property versionLogo [>punk . banner -left " Ver" -right "$::punk::version "] |
||||||
|
>punk .. Property version $::punk::version |
||||||
|
|
||||||
|
>punk .. Property front { |
||||||
|
_|_ |
||||||
|
@ v @ |
||||||
|
~ |
||||||
|
- - |
||||||
|
|_\ /_| |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
} |
||||||
|
>punk .. Property back { |
||||||
|
| |
||||||
|
( | ) |
||||||
|
| |
||||||
|
- - |
||||||
|
|_\ /_| |
||||||
|
/ \ |
||||||
|
_- -_ |
||||||
|
} |
||||||
|
>punk .. Property rhs { |
||||||
|
\\\_ |
||||||
|
\@ > |
||||||
|
| ~ |
||||||
|
\_- -_ |
||||||
|
\\ / |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
} |
||||||
|
>punk .. Property right |
||||||
|
>punk .. PropertyRead right {} { |
||||||
|
return $o_rhs |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
>punk .. Property lhs { |
||||||
|
_/// |
||||||
|
< @/ |
||||||
|
~ | |
||||||
|
_- -_/ |
||||||
|
\ // |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
} |
||||||
|
>punk .. Property left |
||||||
|
>punk .. PropertyRead left {} { |
||||||
|
return $o_lhs |
||||||
|
} |
||||||
|
|
||||||
|
>punk .. Property rhs_air { |
||||||
|
\\\_ |
||||||
|
\@ > |
||||||
|
| ~ |
||||||
|
\_- -_/ |
||||||
|
\\ |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
} |
||||||
|
>punk .. Property lhs_air { |
||||||
|
_/// |
||||||
|
< @/ |
||||||
|
~ | |
||||||
|
\_- -_/ |
||||||
|
// |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
} |
||||||
|
|
||||||
|
>punk .. Property lhs_hips { |
||||||
|
_/// |
||||||
|
< @/ |
||||||
|
~ | |
||||||
|
_- -_ |
||||||
|
\ | | / |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
} |
||||||
|
>punk .. Property rhs_hips { |
||||||
|
\\\_ |
||||||
|
\@ > |
||||||
|
| ~ |
||||||
|
_- -_ |
||||||
|
\ | | / |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
>punk .. Property piss { |
||||||
|
\\\_ |
||||||
|
\@ > |
||||||
|
| ~ |
||||||
|
\_- -_/ |
||||||
|
\\_ .. |
||||||
|
/ \ .. |
||||||
|
_+ +_ . |
||||||
|
} |
||||||
|
|
||||||
|
>punk .. Property poop { |
||||||
|
_/// |
||||||
|
< @/ |
||||||
|
^ | |
||||||
|
_- -_ |
||||||
|
\ \\ / |
||||||
|
//. ~ |
||||||
|
_+_+ @ |
||||||
|
} |
||||||
|
|
||||||
|
>punk .. Method dumpProperties {{object ::>punk}} { |
||||||
|
foreach {p v} [$object .. Properties . pairs] { |
||||||
|
puts $p |
||||||
|
puts [set $v] |
||||||
|
puts \n |
||||||
|
} |
||||||
|
} |
||||||
|
>punk .. Method listProperties {{object ::>punk}} { |
||||||
|
set result {} |
||||||
|
foreach {p v} [$object .. Properties . pairs] { |
||||||
|
lappend result $p [set $v] |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
########################################################## |
||||||
|
#CANDY-CODE |
||||||
|
# |
||||||
|
#!todo - unset etc. |
||||||
|
if {[info proc ::punk::_unknown] eq ""} {rename unknown ::punk::_unknown} |
||||||
|
|
||||||
|
proc ::punk::var {varname {= {}} args} { |
||||||
|
if {${=} == "="} { |
||||||
|
if {[llength $args] > 1} { |
||||||
|
uplevel 1 [list set $varname [uplevel 1 $args]] |
||||||
|
} else { |
||||||
|
uplevel 1 [list set $varname [lindex $args 0]] |
||||||
|
} |
||||||
|
} else { |
||||||
|
uplevel 1 [list set $varname] |
||||||
|
} |
||||||
|
} |
||||||
|
proc unknown {args} { |
||||||
|
if {[lindex $args 1] eq "="} { |
||||||
|
set n [lindex $args 0] |
||||||
|
set v [lindex $args 2] |
||||||
|
#uplevel 1 [string map [list @n@ $n @v@ $v] {proc @n@ {= val} {uplevel 1 set @n@ $val}}] |
||||||
|
uplevel 1 [list interp alias {} $n {} ::punk::var $n] |
||||||
|
|
||||||
|
#uplevel 1 [list trace add variable $n unset [string map [list @n@ $n] {uplevel 1 [list interp alias {} @n@ {}]}]] |
||||||
|
uplevel 1 [list trace add variable $n unset [list interp alias {} $n {}]] |
||||||
|
|
||||||
|
if {[llength $args] > 3} { |
||||||
|
#RHS consists of multiple args; evaluate |
||||||
|
return [uplevel 1 [list set $n [uplevel 1 [lrange $args 2 end]]]] |
||||||
|
} else { |
||||||
|
#RHS is single arg; treat as value |
||||||
|
return [uplevel 1 [list set $n $v]] |
||||||
|
} |
||||||
|
} else { |
||||||
|
#delegate to original 'unknown' command |
||||||
|
uplevel 1 ::punk::_unknown $args |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#Cute names for file I/O |
||||||
|
proc <- filename { |
||||||
|
set fp [open $filename] |
||||||
|
::pattern::K [read $fp] [close $fp] |
||||||
|
} |
||||||
|
proc -> {filename string} { |
||||||
|
set fp [open $filename w] |
||||||
|
puts $fp $string |
||||||
|
close $fp |
||||||
|
} |
||||||
|
proc ->> {filename string} { |
||||||
|
set fp [open $filename a] |
||||||
|
puts $fp $string |
||||||
|
close $fp |
||||||
|
} |
||||||
|
|
||||||
|
#presumably this is to allow calling of standard objects using dotted notation? |
||||||
|
::>pattern .. Create ::> |
||||||
|
::> .. Method item {args} { |
||||||
|
#uplevel #0 $args |
||||||
|
#uplevel #0 [join $args] |
||||||
|
|
||||||
|
uplevel #0 $args |
||||||
|
} |
||||||
|
|
||||||
|
#]]> |
||||||
|
#</code> |
||||||
|
#<files> |
||||||
|
#</files> |
||||||
|
#</xpack> |
||||||
|
#</xml> |
||||||
|
|
||||||
@ -0,0 +1,539 @@ |
|||||||
|
package provide punk [namespace eval punk { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
}] |
||||||
|
|
||||||
|
namespace eval punk::config { |
||||||
|
variable loaded |
||||||
|
variable startup ;#include env overrides |
||||||
|
variable running |
||||||
|
|
||||||
|
set vars [list \ |
||||||
|
scriptlib \ |
||||||
|
color_stdout \ |
||||||
|
color_stderr \ |
||||||
|
logfile_stdout \ |
||||||
|
logfile_stderr \ |
||||||
|
syslog_stdout \ |
||||||
|
syslog_stderr \ |
||||||
|
exec_unknown \ |
||||||
|
] |
||||||
|
#todo pkg punk::config |
||||||
|
|
||||||
|
#defaults |
||||||
|
dict set startup exec_unknown true ;#whether to use exec instead of experimental shellfilter::run |
||||||
|
dict set startup color_stdout [list cyan bold] |
||||||
|
dict set startup color_stderr [list red bold] |
||||||
|
dict set startup syslog_stdout "127.0.0.1:514" |
||||||
|
dict set startup syslog_stderr "127.0.0.1:514" |
||||||
|
#default file logs to logs folder at same location as exe if writable, or empty string |
||||||
|
dict set startup logfile_stdout "" |
||||||
|
dict set startup logfile_stderr "" |
||||||
|
set exefolder [file dirname [info nameofexecutable]] |
||||||
|
set log_folder $exefolder/logs |
||||||
|
dict set startup scriptlib $exefolder/scriptlib |
||||||
|
if {[file exists $log_folder]} { |
||||||
|
if {[file isdirectory $log_folder] && [file writable $log_folder]} { |
||||||
|
dict set startup logfile_stdout $log_folder/repl-exec-stdout.txt |
||||||
|
dict set startup logfile_stderr $log_folder/repl-exec-stderr.txt |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#todo - load/write config file |
||||||
|
|
||||||
|
#env vars override the configuration |
||||||
|
|
||||||
|
#todo - define which configvars are settable in env |
||||||
|
set known_punk_env_vars [list \ |
||||||
|
PUNK_SCRIPTLIB \ |
||||||
|
PUNK_EXECUNKNOWN \ |
||||||
|
PUNK_COLOR_STDERR \ |
||||||
|
PUNK_COLOR_STDOUT \ |
||||||
|
PUNK_LOGFILE_STDOUT \ |
||||||
|
PUNK_LOGFILE_STDERR \ |
||||||
|
PUNK_SYSLOG_STDOUT \ |
||||||
|
PUNK_SYSLOG_STDERR \ |
||||||
|
] |
||||||
|
|
||||||
|
#override with env vars if set |
||||||
|
foreach evar $known_punk_env_vars { |
||||||
|
if {[info exists ::env($evar)]} { |
||||||
|
set f [set ::env($evar)] |
||||||
|
if {$f ne "default"} { |
||||||
|
#e.g PUNK_SCRIPTLIB -> scriptlib |
||||||
|
set varname [string tolower [string range $evar 5 end]] |
||||||
|
dict set startup $varname $f |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set running [dict create] |
||||||
|
set running [dict merge $running $startup] |
||||||
|
} |
||||||
|
|
||||||
|
namespace eval punk { |
||||||
|
proc scriptlibpath {{shortname {}} args} { |
||||||
|
upvar ::punk::config::running running_config |
||||||
|
set scriptlib [dict get $running_config scriptlib] |
||||||
|
if {[string match "lib::*" $shortname]} { |
||||||
|
set relpath [string map [list "lib::" "" "::" "/"] $shortname] |
||||||
|
set relpath [string trimleft $relpath "/"] |
||||||
|
set fullpath $scriptlib/$relpath |
||||||
|
} else { |
||||||
|
set shortname [string trimleft $shortname "/"] |
||||||
|
set fullpath $scriptlib/$shortname |
||||||
|
} |
||||||
|
return $fullpath |
||||||
|
} |
||||||
|
|
||||||
|
#todo - something better - 'previous' rather than reverting to startup |
||||||
|
proc channelcolors {{onoff {}}} { |
||||||
|
upvar ::punk::config::running running_config |
||||||
|
upvar ::punk::config::startup startup_config |
||||||
|
|
||||||
|
if {![string length $onoff]} { |
||||||
|
return [list stdout [dict get $running_config color_stdout] stderr [dict get $running_config color_stderr]] |
||||||
|
} else { |
||||||
|
set lower_onoff [string tolower $onoff] |
||||||
|
if {$lower_onoff in [list true on 1]} { |
||||||
|
dict set running_config color_stdout [dict get $startup_config color_stdout] |
||||||
|
dict set running_config color_stderr [dict get $startup_config color_stderr] |
||||||
|
} elseif {$lower_onoff in [list false off 0]} { |
||||||
|
dict set running_config color_stdout "" |
||||||
|
dict set running_config color_stderr "" |
||||||
|
} else { |
||||||
|
error "channelcolors: invalid value $onoff - expected true|false|on|off|1|0" |
||||||
|
} |
||||||
|
} |
||||||
|
return [list stdout [dict get $running_config color_stdout] stderr [dict get $running_config color_stderr]] |
||||||
|
} |
||||||
|
#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]] |
||||||
|
} |
||||||
|
|
||||||
|
#------------------------------------------------------------------- |
||||||
|
#sh 'test' equivalent - to be used with exitcode of process |
||||||
|
# |
||||||
|
|
||||||
|
#single evaluation to get exitcode |
||||||
|
proc sh_test {args} { |
||||||
|
tailcall run test {*}$args |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#double-evaluation to get true/fals |
||||||
|
#faster tcl equivalents where possible to accuratley provide, and fallthrough to sh for compatibility of unimplemented |
||||||
|
#The problem with fallthrough is that sh/bash etc have a different view of existant files |
||||||
|
#e.g unix files such as /dev/null vs windows devices such as CON,PRN |
||||||
|
#e.g COM1 is mapped as /dev/ttyS1 in wsl (?) |
||||||
|
proc sh_TEST {args} { |
||||||
|
set a1 [lindex $args 0] |
||||||
|
set a2 [lindex $args 1] |
||||||
|
set a3 [lindex $args 2] |
||||||
|
if {[llength $args] == 1} { |
||||||
|
#equivalent of -n STRING |
||||||
|
return [expr {[string length $a1] != 0}] |
||||||
|
} elseif {[llength $args] == 2} { |
||||||
|
switch -- $a1 { |
||||||
|
-b { |
||||||
|
#dubious utility on FreeBSD, windows? |
||||||
|
#FreeBSD has dropped support for block devices - stating 'No serious applications rely on block devices' |
||||||
|
#Linux apparently uses them though |
||||||
|
if{[file exists $a2]} { |
||||||
|
if {[file type $a2] eq "blockSpecial"} { |
||||||
|
return true |
||||||
|
} else { |
||||||
|
return false |
||||||
|
} |
||||||
|
} else { |
||||||
|
return false |
||||||
|
} |
||||||
|
} |
||||||
|
-c { |
||||||
|
#e.g on windows CON,NUL |
||||||
|
if {[file exists $a2]} { |
||||||
|
if {[file type $a2] eq "characterSpecial"} { |
||||||
|
return true |
||||||
|
} else { |
||||||
|
return false |
||||||
|
} |
||||||
|
} else { |
||||||
|
return false |
||||||
|
} |
||||||
|
} |
||||||
|
-d { |
||||||
|
return [file isdirectory $a2] |
||||||
|
} |
||||||
|
-e { |
||||||
|
return [file exists $a2] |
||||||
|
} |
||||||
|
-f { |
||||||
|
#e.g on windows CON,NUL |
||||||
|
if {[file exists $a2]} { |
||||||
|
if {[file type $a2] eq "file"} { |
||||||
|
return true |
||||||
|
} else { |
||||||
|
return false |
||||||
|
} |
||||||
|
} else { |
||||||
|
return false |
||||||
|
} |
||||||
|
} |
||||||
|
-h - |
||||||
|
-L { |
||||||
|
return [expr {[file type $a2] eq "link"}] |
||||||
|
} |
||||||
|
-s { |
||||||
|
if {[file exists $a2] && ([file size $a2] > 0 )} { |
||||||
|
return true |
||||||
|
} else { |
||||||
|
return false |
||||||
|
} |
||||||
|
} |
||||||
|
-S { |
||||||
|
if {[file exists $a2]} { |
||||||
|
if {[file type $a2] eq "socket"} { |
||||||
|
return true |
||||||
|
} else { |
||||||
|
return false |
||||||
|
} |
||||||
|
} else { |
||||||
|
return false |
||||||
|
} |
||||||
|
} |
||||||
|
-x { |
||||||
|
if {[file exists $a2] && [file executable $a2]} { |
||||||
|
return true |
||||||
|
} else { |
||||||
|
return false |
||||||
|
} |
||||||
|
} |
||||||
|
-w { |
||||||
|
if {[file exists $a2] && [file writable $a2]} { |
||||||
|
return true |
||||||
|
} else { |
||||||
|
return false |
||||||
|
} |
||||||
|
} |
||||||
|
-z { |
||||||
|
return [expr {[string length $a2] == 0}] |
||||||
|
} |
||||||
|
-n { |
||||||
|
return [expr {[string length $a2] != 0}] |
||||||
|
} |
||||||
|
default { |
||||||
|
tailcall apply {arglist {uplevel #0 [run test {*}$arglist]} ::} $args |
||||||
|
} |
||||||
|
} |
||||||
|
} elseif {[llength $args] == 3} { |
||||||
|
switch -- $a2 { |
||||||
|
"=" { |
||||||
|
return [string equal $a1 $a3] |
||||||
|
} |
||||||
|
"!=" { |
||||||
|
return [expr {$a1 ne $a3}] |
||||||
|
} |
||||||
|
"-eq" { |
||||||
|
if {![string is integer -strict $a1]} { |
||||||
|
puts stderr "sh_TEST: invalid integer '$a1'" |
||||||
|
return false |
||||||
|
} |
||||||
|
if {![string is integer -strict $a3]} { |
||||||
|
puts stderr "sh_TEST: invalid integer '$a3'" |
||||||
|
return false |
||||||
|
} |
||||||
|
return [expr {$a1 == $a3}] |
||||||
|
} |
||||||
|
"-ge" { |
||||||
|
return [expr {$a1 >= $a3}] |
||||||
|
} |
||||||
|
"-gt" { |
||||||
|
return [expr {$a1 > $a3}] |
||||||
|
} |
||||||
|
"-le" { |
||||||
|
return [expr {$a1 <= $a3}] |
||||||
|
} |
||||||
|
"-lt" { |
||||||
|
return [expr {$a1 < $a3}] |
||||||
|
} |
||||||
|
"-ne" { |
||||||
|
return [expr {$a1 != $a3}] |
||||||
|
} |
||||||
|
default { |
||||||
|
tailcall apply {arglist {uplevel #0 [run test {*}$arglist]} ::} $args |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
tailcall apply {arglist {uplevel #0 [run test {*}$arglist]} ::} $args |
||||||
|
} |
||||||
|
} |
||||||
|
proc sh_echo {args} { |
||||||
|
tailcall run echo {*}$args |
||||||
|
} |
||||||
|
proc sh_ECHO {args} { |
||||||
|
tailcall apply {arglist {uplevel #0 [run echo {*}$arglist]} ::} $args |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#sh style true/false for process exitcode. 0 is true - everything else false |
||||||
|
proc exitcode {c} { |
||||||
|
if {[string is integer -strict $c]} { |
||||||
|
#return [expr {$c == 0}] |
||||||
|
#return true/false to make it clearer we are outputting tcl-boolean inverse mapping from the shell style 0=true |
||||||
|
if {$c == 0} { |
||||||
|
return true |
||||||
|
} else { |
||||||
|
return false |
||||||
|
} |
||||||
|
} else { |
||||||
|
return false |
||||||
|
} |
||||||
|
} |
||||||
|
#------------------------------------------------------------------- |
||||||
|
|
||||||
|
namespace export help aliases alias cdwin cdwindir winpath windir |
||||||
|
namespace ensemble create |
||||||
|
|
||||||
|
#tailcall is important |
||||||
|
#TODO - fix. conflicts with Tk toplevel command "." |
||||||
|
proc ./ {args} { |
||||||
|
set ::punk::last_run_display [list] |
||||||
|
|
||||||
|
if {([llength $args]) && ([lindex $args 0] eq "")} { |
||||||
|
set args [lrange $args 1 end] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {![llength $args]} { |
||||||
|
set out [runout -n ls -aFC] |
||||||
|
#puts stdout $out |
||||||
|
#puts stderr [a+ white]$out[a+] |
||||||
|
set result [pwd] |
||||||
|
set chunklist [list] |
||||||
|
lappend chunklist [list stderr "[a+ white light]$out[a+]\n"] |
||||||
|
lappend chunklist [list stdout $result\n] |
||||||
|
set ::punk::last_run_display $chunklist |
||||||
|
return $result |
||||||
|
} else { |
||||||
|
set a1 [lindex $args 0] |
||||||
|
if {$a1 in [list . ..]} { |
||||||
|
if {$a1 eq ".."} { |
||||||
|
cd $a1 |
||||||
|
} |
||||||
|
tailcall punk::./ {*}[lrange $args 1 end] |
||||||
|
} |
||||||
|
set curdir [pwd] |
||||||
|
set path $curdir/$a1 |
||||||
|
if {[file type $path] eq "file"} { |
||||||
|
if {[string tolower [file extension $path]] in [list ".tcl" ".tm"]} { |
||||||
|
set newargs [lrange $args 1 end] |
||||||
|
set ::argv0 $path |
||||||
|
set ::argc [llength $newargs] |
||||||
|
set ::argv $newargs |
||||||
|
tailcall source $path |
||||||
|
} else { |
||||||
|
puts stderr "Cannot run [file extension $path] file directly ([file tail $path])" |
||||||
|
return [pwd] |
||||||
|
} |
||||||
|
} |
||||||
|
if {[file type $path] eq "directory"} { |
||||||
|
cd $path |
||||||
|
tailcall punk::./ {*}[lrange $args 1 end] |
||||||
|
} |
||||||
|
error "Cannot access path $path" |
||||||
|
} |
||||||
|
} |
||||||
|
proc ../ {args} { |
||||||
|
set ::punk::last_run_display |
||||||
|
if {![llength $args]} { |
||||||
|
cd .. |
||||||
|
} else { |
||||||
|
cd ../[file join {*}$args] |
||||||
|
} |
||||||
|
set out [runout -n ls -aFC] |
||||||
|
set result [pwd] |
||||||
|
#return $out\n[pwd] |
||||||
|
set chunklist [list] |
||||||
|
lappend chunklist [list stderr "[a+ white light]$out[a+]\n"] |
||||||
|
lappend chunklist [list stdout $result\n] |
||||||
|
set ::punk::last_run_display $chunklist |
||||||
|
return $result |
||||||
|
} |
||||||
|
proc ls {args} { |
||||||
|
if {![llength $args]} { |
||||||
|
set args [list [pwd]] |
||||||
|
} |
||||||
|
if {[llength $args] ==1} { |
||||||
|
return [glob -nocomplain -tails -dir [lindex $args 0] *] |
||||||
|
} else { |
||||||
|
set result [dict create] |
||||||
|
foreach a $args { |
||||||
|
set k [file normalize $a] |
||||||
|
set contents [glob -nocomplain -tails -dir $a *] |
||||||
|
dict set result $k $contents |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
proc cdwin {path} { |
||||||
|
set path [punk::winpath $path] |
||||||
|
cd $path |
||||||
|
} |
||||||
|
proc cdwindir {path} { |
||||||
|
set path [punk::winpath $path] |
||||||
|
cd [file dirname $path] |
||||||
|
} |
||||||
|
|
||||||
|
#return list of {chan chunk} elements |
||||||
|
proc help_chunks {} { |
||||||
|
set chunks [list] |
||||||
|
set linesep [string repeat - 76] |
||||||
|
catch { |
||||||
|
package require patternpunk |
||||||
|
#puts -nonewline stderr [>punk . rhs] |
||||||
|
lappend chunks [list stderr [>punk . rhs]] |
||||||
|
} |
||||||
|
set text "" |
||||||
|
set known $::punk::config::known_punk_env_vars |
||||||
|
append text $linesep\n |
||||||
|
append text "punk environment vars:\n" |
||||||
|
append text $linesep\n |
||||||
|
set col1 [string repeat " " 25] |
||||||
|
set col2 [string repeat " " 50] |
||||||
|
foreach v $known { |
||||||
|
set c1 [overtype::left $col1 $v] |
||||||
|
if {[info exists ::env($v)]} { |
||||||
|
set c2 [overtype::left $col2 [set ::env($v)] |
||||||
|
} else { |
||||||
|
set c2 [overtype::right $col2 "(NOT SET)"] |
||||||
|
} |
||||||
|
append text "$c1 $c2\n" |
||||||
|
} |
||||||
|
append text $linesep\n |
||||||
|
lappend chunks [list stdout $text] |
||||||
|
|
||||||
|
set text "" |
||||||
|
append text "Punk commands:\n" |
||||||
|
append text "punk help\n" |
||||||
|
lappend chunks [list stdout $text] |
||||||
|
return $chunks |
||||||
|
} |
||||||
|
proc help {} { |
||||||
|
set chunks [help_chunks] |
||||||
|
foreach chunk $chunks { |
||||||
|
lassign $chunk chan text |
||||||
|
puts -nonewline $chan $text |
||||||
|
} |
||||||
|
} |
||||||
|
#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]}}] |
||||||
|
set matched [lsearch -all -inline $interesting $glob] |
||||||
|
} |
||||||
|
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] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#sh style 'test' and 'exitcode' (0 is false) |
||||||
|
interp alias {} sh_test {} punk::sh_test |
||||||
|
interp alias {} sh_echo {} punk::sh_echo |
||||||
|
interp alias {} sh_TEST {} punk::sh_TEST |
||||||
|
interp alias {} sh_ECHO {} punk::sh_ECHO |
||||||
|
|
||||||
|
|
||||||
|
interp alias {} exitcode {} punk::exitcode |
||||||
|
|
||||||
|
|
||||||
|
#friendly sh aliases (which user may wish to disable e.g if conflicts) |
||||||
|
interp alias {} test {} punk::sh_test ;#not much reason to run 'test' directly in punk shell (or tclsh shell) as returncode not obvious anyway due to use of exec |
||||||
|
interp alias {} TEST {} punk::sh_TEST; #double-evaluation to return tcl true/false from exitcode |
||||||
|
interp alias {} echo {} punk::sh_echo |
||||||
|
interp alias {} ECHO {} punk::sh_ECHO |
||||||
|
|
||||||
|
interp alias {} c {} clear |
||||||
|
interp alias {} a+ {} shellfilter::ansi::+ |
||||||
|
interp alias {} run {} shellrun::run |
||||||
|
interp alias {} runout {} shellrun::runout |
||||||
|
interp alias {} runerr {} shellrun::runerr |
||||||
|
interp alias {} runx {} shellrun::runx |
||||||
|
|
||||||
|
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 |
||||||
|
#---------------------------------------------- |
||||||
|
#git |
||||||
|
interp alias {} gs {} git status |
||||||
|
interp alias {} gl {} git log --oneline --decorate ;#decorate so stdout consistent with what we see on console |
||||||
|
|
||||||
|
#---------------------------------------------- |
||||||
|
interp alias {} l {} ls -aFC ;#wide listing () |
||||||
|
interp alias {} ll {} ls -laFo --color=always |
||||||
|
interp alias {} lw {} ls -aFv --color=always |
||||||
|
interp alias {} ./ {} punk::./ |
||||||
|
interp alias {} ../ {} punk::../ |
||||||
|
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 |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
@ -0,0 +1,377 @@ |
|||||||
|
# vim: set ft=tcl |
||||||
|
# |
||||||
|
package provide shellrun [namespace eval shellrun { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
}] |
||||||
|
#purpose: handle the run commands that call shellfilter::run |
||||||
|
#e.g run,runout,runerr,runx |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#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) |
||||||
|
|
||||||
|
namespace eval shellrun { |
||||||
|
variable runout |
||||||
|
variable runerr |
||||||
|
|
||||||
|
|
||||||
|
proc run {args} { |
||||||
|
set ::punk::last_run_display [list] |
||||||
|
#we provide -nonewline for 'run' even though run doesn't deliver stderr or stdout to the tcl return value |
||||||
|
#This is for compatibility with other runX commands, and the difference is also visible when calling from repl. |
||||||
|
set known_runopts [list "-echo" "-e" "-nonewline" "-n"] |
||||||
|
set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline"] ;#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}] |
||||||
|
if {"-nonewline" in $runopts} { |
||||||
|
set nonewline 1 |
||||||
|
} else { |
||||||
|
set nonewline 0 |
||||||
|
} |
||||||
|
|
||||||
|
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 |
||||||
|
} |
||||||
|
|
||||||
|
proc runout {args} { |
||||||
|
set ::punk::last_run_display [list] |
||||||
|
variable runout |
||||||
|
variable runerr |
||||||
|
set runout "" |
||||||
|
set runerr "" |
||||||
|
|
||||||
|
set known_runopts [list "-echo" "-e" "-nonewline" "-n"] |
||||||
|
set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline"] ;#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}] |
||||||
|
if {"-nonewline" in $runopts} { |
||||||
|
set nonewline 1 |
||||||
|
} else { |
||||||
|
set nonewline 0 |
||||||
|
} |
||||||
|
|
||||||
|
#puts stdout "RUNOUT cmdargs: $cmdargs" |
||||||
|
|
||||||
|
#todo add -data boolean and -data lastwrite to -settings with default being -data all |
||||||
|
# because sometimes we're only interested in last char (e.g to detect something was output) |
||||||
|
|
||||||
|
#set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}] |
||||||
|
# |
||||||
|
#when not echoing - use float-locked so that the repl's stack is bypassed |
||||||
|
if {"-echo" in $runopts} { |
||||||
|
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] |
||||||
|
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||||
|
#set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}] |
||||||
|
} else { |
||||||
|
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] |
||||||
|
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||||
|
} |
||||||
|
|
||||||
|
#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 ] |
||||||
|
|
||||||
|
flush stderr |
||||||
|
flush stdout |
||||||
|
|
||||||
|
shellfilter::stack::remove stdout $stdout_stackid |
||||||
|
shellfilter::stack::remove stderr $stderr_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] |
||||||
|
} |
||||||
|
|
||||||
|
set chunklist [list] |
||||||
|
|
||||||
|
set n [a+] |
||||||
|
set c "" |
||||||
|
if [dict exists $exitinfo exitcode] { |
||||||
|
set code [dict get $exitinfo exitcode] |
||||||
|
if {$code == 0} { |
||||||
|
set c [a+ green] |
||||||
|
} else { |
||||||
|
set c [a+ white bold] |
||||||
|
} |
||||||
|
} else { |
||||||
|
set c [a+ Yellow red bold] |
||||||
|
} |
||||||
|
#exitcode not part of return value for runout - colourcode appropriately |
||||||
|
lappend chunklist [list stderr "$c$exitinfo$n\n"] |
||||||
|
|
||||||
|
|
||||||
|
set chunk "[a+ red bold]stderr[a+]\n" |
||||||
|
if {[string length $::shellrun::runerr]} { |
||||||
|
if {$nonewline} { |
||||||
|
set e [string trimright $::shellrun::runerr \r\n] |
||||||
|
} else { |
||||||
|
set e $::shellrun::runerr |
||||||
|
} |
||||||
|
append chunk "$e\n" |
||||||
|
} |
||||||
|
lappend chunklist [list stderr $chunk] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
lappend chunklist [list stderr "[a+ white bold]stdout[a+]\n"] |
||||||
|
set chunk "" |
||||||
|
if {[string length $::shellrun::runout]} { |
||||||
|
if {$nonewline} { |
||||||
|
set o [string trimright $::shellrun::runout \r\n] |
||||||
|
} else { |
||||||
|
set o $::shellrun::runout |
||||||
|
} |
||||||
|
append chunk "$o\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. |
||||||
|
} |
||||||
|
lappend chunklist [list stdout $chunk] |
||||||
|
|
||||||
|
|
||||||
|
set ::punk::last_run_display $chunklist |
||||||
|
|
||||||
|
if {$nonewline} { |
||||||
|
return [string trimright $::shellrun::runout \r\n] |
||||||
|
} else { |
||||||
|
return $::shellrun::runout |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc runerr {args} { |
||||||
|
set ::punk::last_run_display [list] |
||||||
|
variable runout |
||||||
|
variable runerr |
||||||
|
set runout "" |
||||||
|
set runerr "" |
||||||
|
set known_runopts [list "-echo" "-e" "-nonewline" "-n"] |
||||||
|
set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline"] ;#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 {"-nonewline" in $runopts} { |
||||||
|
set nonewline 1 |
||||||
|
} else { |
||||||
|
set nonewline 0 |
||||||
|
} |
||||||
|
|
||||||
|
if {"-echo" in $runopts} { |
||||||
|
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||||
|
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] |
||||||
|
} else { |
||||||
|
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||||
|
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||||
|
shellfilter::stack::remove stderr $stderr_stackid |
||||||
|
shellfilter::stack::remove stdout $stdout_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] |
||||||
|
} |
||||||
|
|
||||||
|
set chunklist [list] |
||||||
|
|
||||||
|
set n [a+] |
||||||
|
set c "" |
||||||
|
if [dict exists $exitinfo exitcode] { |
||||||
|
set code [dict get $exitinfo exitcode] |
||||||
|
if {$code == 0} { |
||||||
|
set c [a+ green] |
||||||
|
} else { |
||||||
|
set c [a+ white bold] |
||||||
|
} |
||||||
|
} else { |
||||||
|
set c [a+ Yellow red bold] |
||||||
|
} |
||||||
|
#exitcode not part of return value for runout - colourcode appropriately |
||||||
|
lappend chunklist [list stderr "$c$exitinfo$n\n"] |
||||||
|
|
||||||
|
|
||||||
|
lappend chunklist [list stderr "[a+ white bold]stdout[a+]\n"] |
||||||
|
set chunk "" |
||||||
|
if {[string length $::shellrun::runout]} { |
||||||
|
if {$nonewline} { |
||||||
|
set o [string trimright $::shellrun::runout \r\n] |
||||||
|
} else { |
||||||
|
set o $::shellrun::runout |
||||||
|
} |
||||||
|
append chunk "$o\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. |
||||||
|
} |
||||||
|
lappend chunklist [list stdout $chunk] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
set chunk "[a+ red bold]stderr[a+]\n" |
||||||
|
if {[string length $::shellrun::runerr]} { |
||||||
|
if {$nonewline} { |
||||||
|
set e [string trimright $::shellrun::runerr \r\n] |
||||||
|
} else { |
||||||
|
set e $::shellrun::runerr |
||||||
|
} |
||||||
|
append chunk "$e\n" |
||||||
|
} |
||||||
|
lappend chunklist [list stderr $chunk] |
||||||
|
|
||||||
|
|
||||||
|
set ::punk::last_run_display $chunklist |
||||||
|
|
||||||
|
if {$nonewline} { |
||||||
|
return [string trimright $::shellrun::runerr \r\n] |
||||||
|
} |
||||||
|
return $::shellrun::runerr |
||||||
|
} |
||||||
|
|
||||||
|
proc runx {args} { |
||||||
|
set ::punk::last_run_display [list] |
||||||
|
variable last_run_display |
||||||
|
variable runout |
||||||
|
variable runerr |
||||||
|
set runout "" |
||||||
|
set runerr "" |
||||||
|
|
||||||
|
set known_runopts [list "-echo" "-e" "-nonewline" "-n"] |
||||||
|
set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline"] ;#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 - known options $known_runopts" |
||||||
|
} |
||||||
|
} |
||||||
|
set runopts [lmap o $runopts {dict get $aliases $o}] |
||||||
|
if {"-nonewline" in $runopts} { |
||||||
|
set nonewline 1 |
||||||
|
} else { |
||||||
|
set nonewline 0 |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#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 ::shellrun::runerr}] |
||||||
|
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action sink-locked -settings {-varname ::shellrun::runout}] |
||||||
|
} else { |
||||||
|
#set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::shellrun::runerr}] |
||||||
|
#set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::shellrun::runout}] |
||||||
|
|
||||||
|
#float above the repl's tee_to_var to deliberately block it. |
||||||
|
#a var transform is naturally a junction point because there is no flow-through.. |
||||||
|
# - but mark it with -junction 1 just to be explicit |
||||||
|
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -junction 1 -settings {-varname ::shellrun::runerr}] |
||||||
|
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -junction 1 -settings {-varname ::shellrun::runout}] |
||||||
|
} |
||||||
|
|
||||||
|
#set exitinfo [shellfilter::run $cmdargs -teehandle punk -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 stderr $stderr_stackid |
||||||
|
|
||||||
|
|
||||||
|
flush stderr |
||||||
|
flush stdout |
||||||
|
|
||||||
|
|
||||||
|
#set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] |
||||||
|
set chunklist [list] |
||||||
|
lappend chunklist [list stderr "[a+ white bold]stdout[a+]\n"] |
||||||
|
|
||||||
|
set chunk "" |
||||||
|
if {[string length $::shellrun::runout]} { |
||||||
|
append chunk "$::shellrun::runout\n" |
||||||
|
} |
||||||
|
lappend chunklist [list stdout $chunk] |
||||||
|
|
||||||
|
|
||||||
|
set chunk "[a+ red bold]stderr[a+]\n" |
||||||
|
if {[string length $::shellrun::runerr]} { |
||||||
|
append chunk "$::shellrun::runerr\n" |
||||||
|
} |
||||||
|
lappend chunklist [list stderr $chunk] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
set n [a+] |
||||||
|
set c "" |
||||||
|
if [dict exists $exitinfo exitcode] { |
||||||
|
set code [dict get $exitinfo exitcode] |
||||||
|
if {$code == 0} { |
||||||
|
set c [a+ green] |
||||||
|
} else { |
||||||
|
set c [a+ white bold] |
||||||
|
} |
||||||
|
} |
||||||
|
lappend chunklist [list stderr "$c$exitinfo$n\n"] |
||||||
|
|
||||||
|
set ::punk::last_run_display $chunklist |
||||||
|
|
||||||
|
#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] |
||||||
|
|
||||||
|
|
||||||
|
if {[dict exists $exitinfo error]} { |
||||||
|
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||||
|
error [dict get $exitinfo error] |
||||||
|
} |
||||||
|
if {$nonewline} { |
||||||
|
return [list stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n] {*}$exitinfo] |
||||||
|
} |
||||||
|
return [list stdout $::shellrun::runout stderr $::shellrun::runerr {*}$exitinfo] |
||||||
|
} |
||||||
|
} |
||||||
Loading…
Reference in new issue