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