You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
544 lines
19 KiB
544 lines
19 KiB
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 {args} { |
|
set c [lindex $args 0] |
|
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 in [list ".." "../"]} { |
|
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 [list] |
|
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 {} 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 -sb |
|
interp alias {} gl {} git log --oneline --decorate ;#decorate so stdout consistent with what we see on console |
|
interp alias {} glast {} git log -1 HEAD --stat |
|
interp alias {} gconf {} git config --global -l |
|
|
|
#---------------------------------------------- |
|
# ls aliases - note that tcl doesn't exand * but sh_xxx functions pass to sh -c allowing shell expansion |
|
interp alias {} l {} sh_runout -n ls -A ;#plain text listing |
|
#interp alias {} ls {} sh_runout -n ls -AF --color=always |
|
interp alias {} ls {} unknown ls -AF --color=always ;#use unknown to use terminal and allow | more | less |
|
#note that shell globbing with * won't work on unix systems when using unknown/exec |
|
interp alias {} lw {} sh_runout -n ls -AFC --color=always ;#wide listing (use A becaus no extra info on . & ..) |
|
interp alias {} ll {} sh_runout -n ls -laFo --color=always ;#use a instead of A to see perms/owner of . & .. |
|
# -v for natural number sorting not supported on freeBSD. Todo - test at startup and modify aliases? |
|
#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 |
|
} |
|
|
|
}
|
|
|