53 changed files with 35223 additions and 422 deletions
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Binary file not shown.
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,200 @@ |
|||||||
|
#JMN - api should be kept in sync with package patternlib where possible |
||||||
|
# |
||||||
|
|
||||||
|
namespace eval oolib { |
||||||
|
oo::class create collection { |
||||||
|
variable o_data ;#dict |
||||||
|
#variable o_alias |
||||||
|
constructor {} { |
||||||
|
set o_data [dict create] |
||||||
|
} |
||||||
|
method info {} { |
||||||
|
return [dict info $o_data] |
||||||
|
} |
||||||
|
method count {} { |
||||||
|
return [dict size $o_data] |
||||||
|
} |
||||||
|
method isEmpty {} { |
||||||
|
expr {[dict size $o_data] == 0} |
||||||
|
} |
||||||
|
method names {{globOrIdx {}}} { |
||||||
|
if {[llength $globOrIdx]} { |
||||||
|
if {[string is integer -strict $globOrIdx]} { |
||||||
|
set idx $globOrIdx |
||||||
|
if {$idx < 0} { |
||||||
|
set idx "end-[expr {abs($idx + 1)}]" |
||||||
|
} |
||||||
|
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||||
|
error "[self object] no such index : '$idx'" |
||||||
|
} else { |
||||||
|
return $result |
||||||
|
} |
||||||
|
} else { |
||||||
|
#glob |
||||||
|
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||||
|
} |
||||||
|
} else { |
||||||
|
return [dict keys $o_data] |
||||||
|
} |
||||||
|
} |
||||||
|
#like names but without globbing |
||||||
|
method keys {} { |
||||||
|
dict keys $o_data |
||||||
|
} |
||||||
|
method key {{posn 0}} { |
||||||
|
if {$posn < 0} { |
||||||
|
set posn "end-[expr {abs($posn + 1)}]" |
||||||
|
} |
||||||
|
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||||
|
error "[self object] no such index : '$posn'" |
||||||
|
} else { |
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
method hasKey {key} { |
||||||
|
dict exists $o_data $key |
||||||
|
} |
||||||
|
method get {} { |
||||||
|
return $o_data |
||||||
|
} |
||||||
|
method items {} { |
||||||
|
return [dict values $o_data] |
||||||
|
} |
||||||
|
method item {key} { |
||||||
|
if {[string is integer -strict $key]} { |
||||||
|
if {$key >= 0} { |
||||||
|
set valposn [expr {(2*$key) +1}] |
||||||
|
return [lindex $o_data $valposn] |
||||||
|
} else { |
||||||
|
set key "end-[expr {abs($key + 1)}]" |
||||||
|
return [lindex $o_data $key] |
||||||
|
#return [lindex [dict keys $o_data] $key] |
||||||
|
} |
||||||
|
} |
||||||
|
if {[dict exists $o_data $key]} { |
||||||
|
return [dict get $o_data $key] |
||||||
|
} |
||||||
|
} |
||||||
|
#inverse lookup |
||||||
|
method itemKeys {value} { |
||||||
|
set value_indices [lsearch -all [dict values $o_data] $value] |
||||||
|
set keylist [list] |
||||||
|
foreach i $value_indices { |
||||||
|
set idx [expr {(($i + 1) *2) -2}] |
||||||
|
lappend keylist [lindex $o_data $idx] |
||||||
|
} |
||||||
|
return $keylist |
||||||
|
} |
||||||
|
method search {value args} { |
||||||
|
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||||
|
if {"-inline" in $args} { |
||||||
|
return $matches |
||||||
|
} else { |
||||||
|
set keylist [list] |
||||||
|
foreach i $matches { |
||||||
|
set idx [expr {(($i + 1) *2) -2}] |
||||||
|
lappend keylist [lindex $o_data $idx] |
||||||
|
} |
||||||
|
return $keylist |
||||||
|
} |
||||||
|
} |
||||||
|
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||||
|
#review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? |
||||||
|
#method alias {newAlias existingKeyOrAlias} { |
||||||
|
# if {[string is integer -strict $newAlias]} { |
||||||
|
# error "[self object] collection key alias cannot be integer" |
||||||
|
# } |
||||||
|
# if {[string length $existingKeyOrAlias]} { |
||||||
|
# set o_alias($newAlias) $existingKeyOrAlias |
||||||
|
# } else { |
||||||
|
# unset o_alias($newAlias) |
||||||
|
# } |
||||||
|
#} |
||||||
|
#method aliases {{key ""}} { |
||||||
|
# if {[string length $key]} { |
||||||
|
# set result [list] |
||||||
|
# foreach {n v} [array get o_alias] { |
||||||
|
# if {$v eq $key} { |
||||||
|
# lappend result $n $v |
||||||
|
# } |
||||||
|
# } |
||||||
|
# return $result |
||||||
|
# } else { |
||||||
|
# return [array get o_alias] |
||||||
|
# } |
||||||
|
#} |
||||||
|
##if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||||
|
#method realKey {idx} { |
||||||
|
# if {[catch {set o_alias($idx)} key]} { |
||||||
|
# return $idx |
||||||
|
# } else { |
||||||
|
# return $key |
||||||
|
# } |
||||||
|
#} |
||||||
|
method add {value key} { |
||||||
|
if {[string is integer -strict $key]} { |
||||||
|
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||||
|
} |
||||||
|
if {[dict exists $o_data $key]} { |
||||||
|
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||||
|
} |
||||||
|
dict set o_data $key $value |
||||||
|
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||||
|
} |
||||||
|
method remove {idx {endRange ""}} { |
||||||
|
if {[string length $endRange]} { |
||||||
|
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||||
|
} |
||||||
|
if {[string is integer -strict $idx]} { |
||||||
|
if {$idx < 0} { |
||||||
|
set idx "end-[expr {abs($idx+1)}]" |
||||||
|
} |
||||||
|
set key [lindex [dict keys $o_data] $idx] |
||||||
|
set posn $idx |
||||||
|
} else { |
||||||
|
set key $idx |
||||||
|
set posn [lsearch -exact [dict keys $o_data] $key] |
||||||
|
if {$posn < 0} { |
||||||
|
error "[self object] no such index: '$idx' in this collection" |
||||||
|
} |
||||||
|
} |
||||||
|
dict unset o_data $key |
||||||
|
return |
||||||
|
} |
||||||
|
method clear {} { |
||||||
|
set o_data [dict create] |
||||||
|
return |
||||||
|
} |
||||||
|
method reverse_the_collection {} { |
||||||
|
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs |
||||||
|
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. |
||||||
|
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. |
||||||
|
set dictnew [dict create] |
||||||
|
foreach k [lreverse [dict keys $o_data]] { |
||||||
|
dict set dictnew $k [dict get $o_data $k] |
||||||
|
} |
||||||
|
set o_data $dictnew |
||||||
|
return |
||||||
|
} |
||||||
|
#review - cmd as list vs cmd as script? |
||||||
|
method map {cmd} { |
||||||
|
set seed [list] |
||||||
|
dict for {k v} $o_data { |
||||||
|
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||||
|
} |
||||||
|
return $seed |
||||||
|
} |
||||||
|
method objectmap {cmd} { |
||||||
|
set seed [list] |
||||||
|
dict for {k v} $o_data { |
||||||
|
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||||
|
} |
||||||
|
return $seed |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
package provide oolib [namespace eval oolib { |
||||||
|
variable version |
||||||
|
set version 0.1.3 |
||||||
|
}] |
||||||
@ -0,0 +1,455 @@ |
|||||||
|
#<?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 |
||||||
|
package require punk::args |
||||||
|
package require punk::ansi |
||||||
|
package require punk::lib |
||||||
|
#pattern::init |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
::>pattern .. Create ::>punk |
||||||
|
::>punk .. Property license {Public Domain} |
||||||
|
::>punk .. Property logo_ascii [string trim { |
||||||
|
+-----------------------+ |
||||||
|
| Pattern PUNK | |
||||||
|
| . \\\_ . | |
||||||
|
| .*. \@ > .=. | |
||||||
|
| .*.*. | ~ .=.=. | |
||||||
|
|.*.*.*.\_- -_/.=.=.=.| |
||||||
|
| .*.*. \\ .=.=. | |
||||||
|
| .*. / \ .=. | |
||||||
|
| . _+ +_ . | |
||||||
|
+-----------------------+ |
||||||
|
} \n] |
||||||
|
set ::punk::bannerTemplate0 [string trim { |
||||||
|
+-----------------------+ |
||||||
|
| .000000000000000. | |
||||||
|
| .*. \\\_ .=. | |
||||||
|
| .*.*. \@ > .=.=. | |
||||||
|
|.*.*.*. | ~ .=.=.=.| |
||||||
|
| .*.*. \_- -_/ .=.=. | |
||||||
|
| .*. \\ .=. | |
||||||
|
| . / \ . | |
||||||
|
|111111111_+ +_2222222| |
||||||
|
+-----------------------+ |
||||||
|
} \n] |
||||||
|
set ::punk::bannerTemplate [string trim { |
||||||
|
.000000000000000. |
||||||
|
.*. \\\_ .=. |
||||||
|
.*.*. \@ > .=.=. |
||||||
|
.*.*.*. | ~ .=.=.=. |
||||||
|
.*.*. \_- -_/ .=.=. |
||||||
|
.*. \\ .=. |
||||||
|
. / \ . |
||||||
|
111111111_+ +_2222222 |
||||||
|
} \n] |
||||||
|
|
||||||
|
>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 logo2 "\[TCL\\\nPUNK\]" |
||||||
|
>punk .. Method logo3 {{cborder_ctext ""}} { |
||||||
|
set this @this@ |
||||||
|
if {$cborder_ctext eq ""} { |
||||||
|
set cborder "web-seagreen" |
||||||
|
set ctext "web-steelblue" |
||||||
|
} else { |
||||||
|
lassign $cborder_ctext cborder ctext |
||||||
|
} |
||||||
|
return [ textblock::frame -checkargs 0 -type arc -ansiborder [a+ Web-black $cborder] [a+ Web-black $ctext][$this . logo2]] |
||||||
|
} |
||||||
|
>punk .. Property logotk "\[TCL\\\n TK \]" |
||||||
|
proc TCL {args} { |
||||||
|
switch -- [lindex $args 0] { |
||||||
|
TK { |
||||||
|
return [>punk . logotk .] |
||||||
|
#return [textblock::frame -type arc [>punk . logotk]] |
||||||
|
} |
||||||
|
PUNK { |
||||||
|
return [>punk . logo2 .] |
||||||
|
#return [textblock::frame -type arc [>punk . logo2]] |
||||||
|
} |
||||||
|
default { |
||||||
|
return [textblock::join -- [>punk . logo3] " " "\nmodule : patternpunk\nversion: [package present patternpunk]"] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
>punk .. Property logo [>punk . banner] |
||||||
|
>punk .. Method versionLogo {} { |
||||||
|
set this @this@ |
||||||
|
>punk . banner -left " Ver" -right "[$this . version] " |
||||||
|
} |
||||||
|
|
||||||
|
>punk .. Method version {} { |
||||||
|
if {[package provide punk] ne ""} { |
||||||
|
set version $::punk::version |
||||||
|
} else { |
||||||
|
set version "N/A" |
||||||
|
} |
||||||
|
return $version |
||||||
|
} |
||||||
|
|
||||||
|
punk::args::define { |
||||||
|
#Review |
||||||
|
@id -id "::>punk . poses" |
||||||
|
@cmd -name ">punk . poses" -help "Show or list the poses for the Punk mascot" |
||||||
|
-censored -default 1 -type boolean -help "Set true to include mild toilet humour poses" |
||||||
|
-return -default table -choices {names table list dict} |
||||||
|
} |
||||||
|
>punk .. Method poses {args} { |
||||||
|
set argd [punk::args::parse $args withid "::>punk . poses"] |
||||||
|
set censored [dict get $argd opts -censored] |
||||||
|
set return [dict get $argd opts -return] |
||||||
|
|
||||||
|
set poses [list {*}{ |
||||||
|
front |
||||||
|
back |
||||||
|
lhs |
||||||
|
left |
||||||
|
rhs |
||||||
|
right |
||||||
|
lhs_air |
||||||
|
rhs_air |
||||||
|
lhs_hips |
||||||
|
rhs_hips |
||||||
|
lhs_bend |
||||||
|
rhs_bend |
||||||
|
lhs_thrust |
||||||
|
rhs_thrust |
||||||
|
}] |
||||||
|
if {!$censored} { |
||||||
|
#allow toilet humour |
||||||
|
lappend poses piss poop |
||||||
|
} |
||||||
|
switch -- $return { |
||||||
|
names { |
||||||
|
return $poses |
||||||
|
} |
||||||
|
list { |
||||||
|
set result [list] |
||||||
|
foreach pose $poses { |
||||||
|
lappend result [list $pose [>punk . $pose]] |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
dict { |
||||||
|
set result [dict create] |
||||||
|
foreach pose $poses { |
||||||
|
dict set result $pose [>punk . $pose] |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
table { |
||||||
|
set cells [list] |
||||||
|
foreach pose $poses { |
||||||
|
lappend cells "$pose\n\n[>punk . $pose]" |
||||||
|
} |
||||||
|
return [textblock::list_as_table -show_hseps 1 -columns 4 $cells] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
>punk .. Property front [string trim { |
||||||
|
_|_ |
||||||
|
@ v @ |
||||||
|
~ |
||||||
|
- - |
||||||
|
|_\ /_| |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
} \n] |
||||||
|
>punk .. Property front_2003 [string trim [string map "% \u2003" { |
||||||
|
_|_ |
||||||
|
@%v%@ |
||||||
|
%~% |
||||||
|
-%%%- |
||||||
|
|_\%/_| |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
}] \n] |
||||||
|
>punk .. Property back [string trim { |
||||||
|
| |
||||||
|
( | ) |
||||||
|
| |
||||||
|
- - |
||||||
|
|_\ /_| |
||||||
|
/ \ |
||||||
|
_- -_ |
||||||
|
} \n] |
||||||
|
>punk .. Property rhs [string trim { |
||||||
|
\\\_ |
||||||
|
\@ > |
||||||
|
| ~ |
||||||
|
\_- -_ |
||||||
|
\\ / |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
} \n] |
||||||
|
>punk .. Property rhs_2003 [string trim [string map "% \u2003" { |
||||||
|
\\\_ |
||||||
|
\@%%> |
||||||
|
|%~ |
||||||
|
\_-%%%-_ |
||||||
|
\\ / |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
}] \n] |
||||||
|
>punk .. Property right |
||||||
|
>punk .. PropertyRead right {} { |
||||||
|
return $o_rhs |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
>punk .. Property lhs [string trim { |
||||||
|
_/// |
||||||
|
< @/ |
||||||
|
~ | |
||||||
|
_- -_/ |
||||||
|
\ // |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
} \n] |
||||||
|
>punk .. Property lhs_2003 [string trim [string map "% \u2003" { |
||||||
|
_/// |
||||||
|
<%%@/ |
||||||
|
~%| |
||||||
|
_-%%%-_/ |
||||||
|
\ // |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
}] \n] |
||||||
|
>punk .. Property left |
||||||
|
>punk .. PropertyRead left {} { |
||||||
|
return $o_lhs |
||||||
|
} |
||||||
|
|
||||||
|
>punk .. Property rhs_air [string trim { |
||||||
|
\\\_ |
||||||
|
\@ > |
||||||
|
| ~ |
||||||
|
\_- -_/ |
||||||
|
\\ |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
} \n] |
||||||
|
>punk .. Property lhs_air [string trim { |
||||||
|
_/// |
||||||
|
< @/ |
||||||
|
~ | |
||||||
|
\_- -_/ |
||||||
|
// |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
} \n] |
||||||
|
|
||||||
|
>punk .. Property lhs_hips [string trim { |
||||||
|
_/// |
||||||
|
< @/ |
||||||
|
~ | |
||||||
|
_- -_ |
||||||
|
\ | | / |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
} \n] |
||||||
|
>punk .. Property rhs_hips [string trim { |
||||||
|
\\\_ |
||||||
|
\@ > |
||||||
|
| ~ |
||||||
|
_- -_ |
||||||
|
\ | | / |
||||||
|
/ \ |
||||||
|
_+ +_ |
||||||
|
} \n] |
||||||
|
|
||||||
|
|
||||||
|
>punk .. Property piss [string trim { |
||||||
|
\\\_ |
||||||
|
\@ > |
||||||
|
| ~ |
||||||
|
\_- -_/ |
||||||
|
\\_ .. |
||||||
|
/ \ .. |
||||||
|
_+ +_ . |
||||||
|
} \n] |
||||||
|
|
||||||
|
>punk .. Property poop [string trim { |
||||||
|
_/// |
||||||
|
< @/ |
||||||
|
~ | |
||||||
|
_- -_ |
||||||
|
\ \\ / |
||||||
|
//. ~ |
||||||
|
_+_+ @ |
||||||
|
} \n] |
||||||
|
|
||||||
|
>punk .. Property lhs_bend [string trim { |
||||||
|
_/// |
||||||
|
< @/ |
||||||
|
~ | |
||||||
|
_- -_ |
||||||
|
\ \\ / |
||||||
|
// |
||||||
|
_+_+ |
||||||
|
} \n] |
||||||
|
>punk .. Property lhs_thrust [string trim { |
||||||
|
_/// |
||||||
|
< @/ |
||||||
|
~ | |
||||||
|
_- -_ |
||||||
|
\ // / |
||||||
|
\\ |
||||||
|
_+_+ |
||||||
|
} \n] |
||||||
|
>punk .. Property rhs_bend [string trim { |
||||||
|
\\\_ |
||||||
|
\@ > |
||||||
|
| ~ |
||||||
|
_- -_ |
||||||
|
\ // / |
||||||
|
\\ |
||||||
|
+_+_ |
||||||
|
} \n] |
||||||
|
>punk .. Property rhs_thrust [string trim { |
||||||
|
\\\_ |
||||||
|
\@ > |
||||||
|
| ~ |
||||||
|
_- -_ |
||||||
|
\ \\ / |
||||||
|
// |
||||||
|
+_+_ |
||||||
|
} \n] |
||||||
|
|
||||||
|
>punk .. Property fossil [punk::args::lib::tstr [string trim { |
||||||
|
.. |
||||||
|
> < |
||||||
|
\ / v |
||||||
|
v \\_/ |
||||||
|
\/\\ v . |
||||||
|
v_ /|\/ / |
||||||
|
\__/ |
||||||
|
} \n]] |
||||||
|
|
||||||
|
>punk .. Method deck {args} { |
||||||
|
#todo - themes? |
||||||
|
set this @this@ |
||||||
|
set RST [a] |
||||||
|
set punk_colour [a+ term-71] ;#term-darkseagreen4-b |
||||||
|
set hbar_colour [a+ web-silver] |
||||||
|
set vbar_colour [a+ web-steelblue] |
||||||
|
set border_colour [a+ web-lightslategray] |
||||||
|
set frame_type arc |
||||||
|
set punk $punk_colour[$this . lhs_air]$RST |
||||||
|
package require punk::args |
||||||
|
set standard_frame_types [textblock::frametypes] |
||||||
|
set argd [punk::args::parse $args withdef [tstr -return string { |
||||||
|
@id -id "::>punk . deck" |
||||||
|
@cmd -name "deck" -help "Punk Deck mascot" |
||||||
|
-frame -default arc -choices "${$standard_frame_types}" -choicerestricted 0 -choiceprefix 1 |
||||||
|
-boxmap -default {} -type dict |
||||||
|
-boxlimits -default {hl vl tlc blc trc brc} -help "Limit the border box to listed elements." |
||||||
|
-border_colour -default ${$border_colour} -type ansistring -regexprepass {^$} -validationtransform { |
||||||
|
-function stripansi -maxsize 0 |
||||||
|
} |
||||||
|
-title -default "PATTERN" -type string |
||||||
|
-subtitle -default "PUNK" -type string |
||||||
|
@values -max 0 |
||||||
|
}]] |
||||||
|
set frame_type [dict get $argd opts -frame] |
||||||
|
set box_map [dict get $argd opts -boxmap] |
||||||
|
set box_limits [dict get $argd opts -boxlimits] |
||||||
|
set border_colour [dict get $argd opts -border_colour] |
||||||
|
set title [dict get $argd opts -title] |
||||||
|
set subtitle [dict get $argd opts -subtitle] |
||||||
|
set punkdeck [overtype::right [overtype::left [textblock::frame -ansiborder $border_colour -type $frame_type -boxmap $box_map -boxlimits $box_limits -title $hbar_colour$title$RST -subtitle $hbar_colour$subtitle$RST $punk] "$vbar_colour\n\n\P\nU\nN\nK$RST"] "$vbar_colour\n\nD\nE\nC\nK"] |
||||||
|
} |
||||||
|
|
||||||
|
#TODO - reuse textblock::gcross arguments - but reorder for error display |
||||||
|
>punk .. Method gcross {{size 1} args} { |
||||||
|
package require textblock |
||||||
|
set argd [punk::args::parse [list {*}$args $size] withid ::textblock::gcross] |
||||||
|
textblock::gcross {*}$args $size |
||||||
|
} |
||||||
|
|
||||||
|
>punk .. Method dumpProperties {{object ::>punk}} { |
||||||
|
set text "" |
||||||
|
foreach {p v} [$object .. Properties . pairs] { |
||||||
|
append text $p \n |
||||||
|
append text [set $v] \n \n |
||||||
|
} |
||||||
|
return $text |
||||||
|
} |
||||||
|
>punk .. Method listProperties {{object ::>punk}} { |
||||||
|
set result {} |
||||||
|
foreach {p v} [$object .. Properties . pairs] { |
||||||
|
lappend result $p [set $v] |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
########################################################## |
||||||
|
#CANDY-CODE |
||||||
|
# |
||||||
|
|
||||||
|
#Cute names for file I/O |
||||||
|
proc <- filename { |
||||||
|
set fp [open $filename] |
||||||
|
::patternpunk:lib::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 |
||||||
|
} |
||||||
|
::> .. DefaultMethod item |
||||||
|
namespace eval patternpunk::lib { |
||||||
|
proc K {x y} {return $x} |
||||||
|
} |
||||||
|
package provide patternpunk [namespace eval patternpunk { |
||||||
|
variable version |
||||||
|
|
||||||
|
set version 1.1.1 |
||||||
|
}] |
||||||
|
#]]> |
||||||
|
#</code> |
||||||
|
#<files> |
||||||
|
#</files> |
||||||
|
#</xpack> |
||||||
|
#</xml> |
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,158 @@ |
|||||||
|
#punkapps app manager |
||||||
|
# deck cli |
||||||
|
|
||||||
|
namespace eval punk::mod::cli { |
||||||
|
namespace export help list run |
||||||
|
namespace ensemble create |
||||||
|
|
||||||
|
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown |
||||||
|
if 0 { |
||||||
|
proc _unknown {ns args} { |
||||||
|
puts stderr "punk::mod::cli::_unknown '$ns' '$args'" |
||||||
|
puts stderr "punk::mod::cli::help $args" |
||||||
|
puts stderr "arglen:[llength $args]" |
||||||
|
punk::mod::cli::help {*}$args |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#cli must have _init method - usually used to load commandsets lazily |
||||||
|
# |
||||||
|
variable initialised 0 |
||||||
|
proc _init {args} { |
||||||
|
variable initialised |
||||||
|
if {$initialised} { |
||||||
|
return |
||||||
|
} |
||||||
|
#... |
||||||
|
set initialised 1 |
||||||
|
} |
||||||
|
|
||||||
|
proc help {args} { |
||||||
|
set basehelp [punk::mix::base help {*}$args] |
||||||
|
#namespace export |
||||||
|
return $basehelp |
||||||
|
} |
||||||
|
proc getraw {appname} { |
||||||
|
set app_folders [punk::config::configure running apps] |
||||||
|
#todo search each app folder |
||||||
|
set bases [::list] |
||||||
|
set versions [::list] |
||||||
|
set mains [::list] |
||||||
|
set appinfo [::list bases {} mains {} versions {}] |
||||||
|
|
||||||
|
foreach containerfolder $app_folders { |
||||||
|
lappend bases $containerfolder |
||||||
|
if {[file exists $containerfolder]} { |
||||||
|
if {[file exists $containerfolder/$appname/main.tcl]} { |
||||||
|
#exact match - only return info for the exact one specified |
||||||
|
set namematches $appname |
||||||
|
set parts [split $appname -] |
||||||
|
} else { |
||||||
|
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] |
||||||
|
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||||
|
} |
||||||
|
foreach nm $namematches { |
||||||
|
set mainfile $containerfolder/$nm/main.tcl |
||||||
|
set parts [split $nm -] |
||||||
|
if {[llength $parts] == 1} { |
||||||
|
set ver "" |
||||||
|
} else { |
||||||
|
set ver [lindex $parts end] |
||||||
|
} |
||||||
|
if {$ver ni $versions} { |
||||||
|
lappend versions $ver |
||||||
|
lappend mains $ver $mainfile |
||||||
|
} else { |
||||||
|
puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" |
||||||
|
} |
||||||
|
} |
||||||
|
dict set appinfo versions $versions |
||||||
|
#todo - natsort! |
||||||
|
set sorted_versions [lsort $versions] |
||||||
|
set latest [lindex $sorted_versions 0] |
||||||
|
if {$latest eq "" && [llength $sorted_versions] > 1} { |
||||||
|
set latest [lindex $sorted_versions 1] |
||||||
|
} |
||||||
|
dict set appinfo latest $latest |
||||||
|
|
||||||
|
dict set appinfo bases $bases |
||||||
|
dict set appinfo mains $mains |
||||||
|
return $appinfo |
||||||
|
} |
||||||
|
|
||||||
|
proc list {{glob *}} { |
||||||
|
set apps_folder [punk::config::configure running apps] |
||||||
|
if {[file exists $apps_folder]} { |
||||||
|
if {[file exists $apps_folder/$glob]} { |
||||||
|
#tailcall source $apps_folder/$glob/main.tcl |
||||||
|
return $glob |
||||||
|
} |
||||||
|
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] |
||||||
|
if {[llength $apps] == 0} { |
||||||
|
if {[string first * $glob] <0 && [string first ? $glob] <0} { |
||||||
|
#no glob chars supplied - only launch if exact match for name part |
||||||
|
set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] |
||||||
|
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||||
|
if {[llength $namematches] > 0} { |
||||||
|
set latest [lindex $namematches end] |
||||||
|
lassign $latest nm ver |
||||||
|
#tailcall source $apps_folder/$latest/main.tcl |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $apps |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#todo - way to launch as separate process |
||||||
|
# solo-opts only before appname - args following appname are passed to the app |
||||||
|
proc run {args} { |
||||||
|
set nameposn [lsearch -not $args -*] |
||||||
|
if {$nameposn < 0} { |
||||||
|
error "punkapp::run unable to determine application name" |
||||||
|
} |
||||||
|
set appname [lindex $args $nameposn] |
||||||
|
set controlargs [lrange $args 0 $nameposn-1] |
||||||
|
set appargs [lrange $args $nameposn+1 end] |
||||||
|
|
||||||
|
set appinfo [punk::mod::cli::getraw $appname] |
||||||
|
if {[llength [dict get $appinfo versions]]} { |
||||||
|
set ver [dict get $appinfo latest] |
||||||
|
puts stdout "info: $appinfo" |
||||||
|
set ::argc [llength $appargs] |
||||||
|
set ::argv $appargs |
||||||
|
source [dict get $appinfo mains $ver] |
||||||
|
if {"-hideconsole" in $controlargs} { |
||||||
|
puts stderr "attempting console hide" |
||||||
|
#todo - something better - a callback when window mapped? |
||||||
|
after 500 {::punkapp::hide_console} |
||||||
|
} |
||||||
|
return $appinfo |
||||||
|
} else { |
||||||
|
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
namespace eval punk::mod::cli { |
||||||
|
proc _cli {args} { |
||||||
|
#don't use tailcall - base uses info level to determine caller |
||||||
|
::punk::mix::base::_cli {*}$args |
||||||
|
} |
||||||
|
variable default_command help |
||||||
|
package require punk::mix::base |
||||||
|
package require punk::overlay |
||||||
|
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||||
|
} |
||||||
|
|
||||||
|
package provide punk::mod [namespace eval punk::mod { |
||||||
|
variable version |
||||||
|
set version 0.1.1 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -0,0 +1,192 @@ |
|||||||
|
|
||||||
|
|
||||||
|
package require punk::mix::util |
||||||
|
package require punk::args |
||||||
|
|
||||||
|
tcl::namespace::eval ::punk::overlay { |
||||||
|
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||||
|
# extend an ensemble-like routine with the routines in some namespace |
||||||
|
# |
||||||
|
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||||
|
# |
||||||
|
proc custom_from_base {routine base} { |
||||||
|
if {![tcl::string::match ::* $routine]} { |
||||||
|
set resolved [uplevel 1 [list ::tcl::namespace::which $routine]] |
||||||
|
if {$resolved eq {}} { |
||||||
|
error [list {no such routine} $routine] |
||||||
|
} |
||||||
|
set routine $resolved |
||||||
|
} |
||||||
|
set routinens [tcl::namespace::qualifiers $routine] |
||||||
|
if {$routinens eq {::}} { |
||||||
|
set routinens {} |
||||||
|
} |
||||||
|
set routinetail [tcl::namespace::tail $routine] |
||||||
|
|
||||||
|
if {![tcl::string::match ::* $base]} { |
||||||
|
set base [uplevel 1 [ |
||||||
|
list [tcl::namespace::which namespace] current]]::$base |
||||||
|
} |
||||||
|
|
||||||
|
if {![tcl::namespace::exists $base]} { |
||||||
|
error [list {no such namespace} $base] |
||||||
|
} |
||||||
|
|
||||||
|
set base [tcl::namespace::eval $base [ |
||||||
|
list [tcl::namespace::which namespace] current]] |
||||||
|
|
||||||
|
|
||||||
|
#while 1 { |
||||||
|
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||||
|
# if {[namespace which $renamed] eq {}} break |
||||||
|
#} |
||||||
|
|
||||||
|
tcl::namespace::eval $routine [ |
||||||
|
::list tcl::namespace::ensemble configure $routine -unknown [ |
||||||
|
::list ::apply {{base ensemble subcommand args} { |
||||||
|
::list ${base}::_redirected $ensemble $subcommand |
||||||
|
}} $base |
||||||
|
] |
||||||
|
] |
||||||
|
|
||||||
|
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||||
|
#namespace eval ${routine}::util { |
||||||
|
#::namespace import ::punk::mix::util::* |
||||||
|
#} |
||||||
|
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||||
|
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||||
|
# ::namespace import <base>::lib::* |
||||||
|
#}] |
||||||
|
|
||||||
|
tcl::namespace::eval ${routine}::lib [tcl::string::map [list <base> $base <routine> $routine] { |
||||||
|
if {[tcl::namespace::exists <base>::lib]} { |
||||||
|
::set current_paths [tcl::namespace::path] |
||||||
|
if {"<routine>" ni $current_paths} { |
||||||
|
::lappend current_paths <routine> |
||||||
|
} |
||||||
|
tcl::namespace::path $current_paths |
||||||
|
} |
||||||
|
}] |
||||||
|
|
||||||
|
tcl::namespace::eval $routine { |
||||||
|
::set exportlist [::list] |
||||||
|
::foreach cmd [tcl::info::commands [tcl::namespace::current]::*] { |
||||||
|
::set c [tcl::namespace::tail $cmd] |
||||||
|
if {![tcl::string::match _* $c]} { |
||||||
|
::lappend exportlist $c |
||||||
|
} |
||||||
|
} |
||||||
|
tcl::namespace::export {*}$exportlist |
||||||
|
} |
||||||
|
|
||||||
|
return $routine |
||||||
|
} |
||||||
|
punk::args::define { |
||||||
|
@id -id ::punk::overlay::import_commandset |
||||||
|
@cmd -name punk::overlay::import_commandset\ |
||||||
|
-summary\ |
||||||
|
"Import commands into caller's namespace with optional prefix and separator."\ |
||||||
|
-help\ |
||||||
|
"Import commands that have been exported by another namespace into the caller's |
||||||
|
namespace. Usually a prefix and optionally a separator should be used. |
||||||
|
This is part of the punk::mix CLI commandset infrastructure - design in flux. |
||||||
|
Todo - .toml configuration files for defining CLI configurations." |
||||||
|
@values |
||||||
|
prefix -type string |
||||||
|
separator -type string -help\ |
||||||
|
"A string, usually punctuation, to separate the prefix and the command name |
||||||
|
of the final imported command. The value \"::\" is disallowed in this context." |
||||||
|
cmdnamespace -type string -help\ |
||||||
|
"Namespace from which to import commands. Commands are those that have been exported." |
||||||
|
} |
||||||
|
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||||
|
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||||
|
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||||
|
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||||
|
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||||
|
#want the convenience of using lib:xxx with commands coming from those packages. |
||||||
|
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||||
|
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||||
|
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||||
|
proc import_commandset {prefix separator cmdnamespace} { |
||||||
|
set bad_seps [list "::"] |
||||||
|
if {$separator in $bad_seps} { |
||||||
|
error "import_commandset invalid separator '$separator'" |
||||||
|
} |
||||||
|
if {$prefix in $bad_seps} { |
||||||
|
error "import_commandset invalid prefix '$prefix'" |
||||||
|
} |
||||||
|
if {"$prefix$separator" in $bad_seps} { |
||||||
|
error "import_commandset invalid prefix/separator combination '$prefix$separator'" |
||||||
|
} |
||||||
|
if {"[string index $prefix end][string index $separator 0]" in $bad_seps} { |
||||||
|
error "import_commandset invalid prefix/separator combination '$prefix$separator'" |
||||||
|
} |
||||||
|
#review - do we allow prefixes/separators such as a::b? |
||||||
|
|
||||||
|
#namespace may or may not be a package |
||||||
|
# allow with or without leading :: |
||||||
|
if {[tcl::string::range $cmdnamespace 0 1] eq "::"} { |
||||||
|
set cmdpackage [tcl::string::range $cmdnamespace 2 end] |
||||||
|
} else { |
||||||
|
set cmdpackage $cmdnamespace |
||||||
|
set cmdnamespace ::$cmdnamespace |
||||||
|
} |
||||||
|
|
||||||
|
if {![tcl::namespace::exists $cmdnamespace]} { |
||||||
|
#only do package require if the namespace not already present |
||||||
|
catch {package require $cmdpackage} pkg_load_info |
||||||
|
#recheck |
||||||
|
if {![tcl::namespace::exists $cmdnamespace]} { |
||||||
|
set prov [package provide $cmdpackage] |
||||||
|
if {[tcl::string::length $prov]} { |
||||||
|
set provinfo "(package $cmdpackage is present with version $prov)" |
||||||
|
} else { |
||||||
|
set provinfo "(package $cmdpackage not present)" |
||||||
|
} |
||||||
|
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||||
|
|
||||||
|
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||||
|
tcl::namespace::eval ${cmdnamespace}::lib [tcl::string::map [list <cmdns> $cmdnamespace] { |
||||||
|
::set nspaths [tcl::namespace::path] |
||||||
|
if {"<cmdns>" ni $nspaths} { |
||||||
|
::lappend nspaths <cmdns> |
||||||
|
} |
||||||
|
tcl::namespace::path $nspaths |
||||||
|
}] |
||||||
|
|
||||||
|
set imported_commands [list] |
||||||
|
set imported_tails [list] |
||||||
|
set nscaller [uplevel 1 [list tcl::namespace::current]] |
||||||
|
if {[catch { |
||||||
|
#review - noclobber? |
||||||
|
tcl::namespace::eval ${nscaller}::temp_import [list tcl::namespace::import ${cmdnamespace}::*] |
||||||
|
foreach cmd [tcl::info::commands ${nscaller}::temp_import::*] { |
||||||
|
set cmdtail [tcl::namespace::tail $cmd] |
||||||
|
if {$cmdtail eq "_default"} { |
||||||
|
set import_as ${nscaller}::${prefix} |
||||||
|
} else { |
||||||
|
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||||
|
} |
||||||
|
rename $cmd $import_as |
||||||
|
lappend imported_commands $import_as |
||||||
|
lappend imported_tails [namespace tail $import_as] |
||||||
|
} |
||||||
|
#make imported commands exported so they are available to the ensemble |
||||||
|
tcl::namespace::eval ${nscaller} [list namespace export {*}$imported_tails] |
||||||
|
} errM]} { |
||||||
|
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||||
|
puts stderr "err: $errM" |
||||||
|
} |
||||||
|
return $imported_commands |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
package provide punk::overlay [tcl::namespace::eval punk::overlay { |
||||||
|
variable version |
||||||
|
set version 0.1.1 |
||||||
|
}] |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,897 @@ |
|||||||
|
# vim: set ft=tcl |
||||||
|
# |
||||||
|
#purpose: handle the run commands that call shellfilter::run |
||||||
|
#e.g run,runout,runerr,runx |
||||||
|
|
||||||
|
package require shellfilter |
||||||
|
package require punk::ansi |
||||||
|
|
||||||
|
#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 PUNKARGS |
||||||
|
variable runout |
||||||
|
variable runerr |
||||||
|
|
||||||
|
#do we need these? |
||||||
|
#variable punkout |
||||||
|
#variable punkerr |
||||||
|
|
||||||
|
#some ugly coupling with punk/punk::config for now |
||||||
|
#todo - something better |
||||||
|
if {[info exists ::punk::config::configdata]} { |
||||||
|
set conf_running [punk::config::configure running] |
||||||
|
set syslog_stdout [dict get $conf_running syslog_stdout] |
||||||
|
set syslog_stderr [dict get $conf_running syslog_stderr] |
||||||
|
set logfile_stdout [dict get $conf_running logfile_stdout] |
||||||
|
set logfile_stderr [dict get $conf_running logfile_stderr] |
||||||
|
} else { |
||||||
|
lassign [list "" "" "" ""] syslog_stdout syslog_stderr logfile_stdout logfile_stderr |
||||||
|
} |
||||||
|
if {"punkshout" ni [shellfilter::stack::items]} { |
||||||
|
set outdevice [shellfilter::stack::new punkshout -settings [list -tag "punkshout" -buffering none -raw 1 -syslog $syslog_stdout -file $logfile_stdout]] |
||||||
|
set out [dict get $outdevice localchan] |
||||||
|
} else { |
||||||
|
set out [dict get [shellfilter::stack::item punkshout] device localchan] |
||||||
|
} |
||||||
|
if {"punksherr" ni [shellfilter::stack::items]} { |
||||||
|
set errdevice [shellfilter::stack::new punksherr -settings [list -tag "punksherr" -buffering none -raw 1 -syslog $syslog_stderr -file $logfile_stderr]] |
||||||
|
set err [dict get $errdevice localchan] |
||||||
|
} else { |
||||||
|
set err [dict get [shellfilter::stack::item punksherr] device localchan] |
||||||
|
} |
||||||
|
|
||||||
|
namespace import ::punk::ansi::a+ |
||||||
|
namespace import ::punk::ansi::a |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#repltelemetry - additional/alternative display info used in a repl context i.e info directed towards the screen |
||||||
|
#todo - package up in repltelemetry module and rewrite proc based on whether the module was found/loaded. |
||||||
|
#somewhat strong coupling to punk - but let's try to behave decently if it's not loaded |
||||||
|
#The last_run_display is actually intended for the repl - but is resident in the punk namespace with a view to the possibility of a different repl being in use. |
||||||
|
proc set_last_run_display {chunklist} { |
||||||
|
#chunklist as understood by the |
||||||
|
if {![info exists ::punk::repltelemetry_emmitters]} { |
||||||
|
namespace eval ::punk { |
||||||
|
variable repltelemetry_emmitters |
||||||
|
set repltelemetry_emmitters "shellrun" |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {"shellrun" ni $::punk::repltelemetry_emmitters} { |
||||||
|
lappend punk::repltelemetry_emmitters "shellrun" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#most basic of validity tests here.. just that it is a list (can be empty). We don't want to duplicate or over-constrain the way repls/shells/terminals interpet the info |
||||||
|
if {[catch {llength $chunklist} errMsg]} { |
||||||
|
error "set_last_run_display expects a list. Value supplied doesn't appear to be a well formed tcl list. '$errMsg'" |
||||||
|
} |
||||||
|
#todo - |
||||||
|
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#maintenance: similar used in punk::ns & punk::winrun |
||||||
|
#todo - take runopts + aliases as args |
||||||
|
#longopts must be passed as a single item ie --timeout=100 not --timeout 100 |
||||||
|
proc get_run_opts {arglist} { |
||||||
|
if {[catch { |
||||||
|
set callerinfo [info level -1] |
||||||
|
} errM]} { |
||||||
|
set caller "" |
||||||
|
} else { |
||||||
|
set caller [lindex $callerinfo 0] |
||||||
|
} |
||||||
|
|
||||||
|
#we provide -nonewline even 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" "-tcl" "-debug"] |
||||||
|
set known_longopts [list "--timeout"] |
||||||
|
set known_longopts_msg "" |
||||||
|
foreach lng $known_longopts { |
||||||
|
append known_longopts_msg "${lng}=val " |
||||||
|
} |
||||||
|
set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline" "-tcl" "-tcl" "-debug" "-debug"] ;#include map to self |
||||||
|
set runopts [list] |
||||||
|
set runoptslong [list] |
||||||
|
set cmdargs [list] |
||||||
|
|
||||||
|
set idx_first_cmdarg [lsearch -not $arglist "-*"] |
||||||
|
|
||||||
|
set allopts [lrange $arglist 0 $idx_first_cmdarg-1] |
||||||
|
set cmdargs [lrange $arglist $idx_first_cmdarg end] |
||||||
|
foreach o $allopts { |
||||||
|
if {[string match --* $o]} { |
||||||
|
lassign [split $o =] flagpart valpart |
||||||
|
if {$valpart eq ""} { |
||||||
|
error "$caller: longopt $o seems to be missing a value - must be of form --option=value" |
||||||
|
} |
||||||
|
if {$flagpart ni $known_longopts} { |
||||||
|
error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" |
||||||
|
} |
||||||
|
lappend runoptslong $flagpart $valpart |
||||||
|
} else { |
||||||
|
if {$o ni $known_runopts} { |
||||||
|
error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" |
||||||
|
} |
||||||
|
lappend runopts [dict get $aliases $o] |
||||||
|
} |
||||||
|
} |
||||||
|
return [list runopts $runopts runoptslong $runoptslong cmdargs $cmdargs] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#todo - investigate cause of punk86 run hanging sometimes. An 'after 500' before exit in the called script fixes the issue. punk87 doesn't seem to be affected. |
||||||
|
lappend PUNKARGS [list { |
||||||
|
@id -id ::shellrun::run |
||||||
|
@leaders -min 0 -max 0 |
||||||
|
@opts |
||||||
|
-nonewline -type none |
||||||
|
-tcl -type none -default 0 |
||||||
|
-debug -type none -default 0 |
||||||
|
--timeout= -type integer |
||||||
|
@values -min 1 -max -1 |
||||||
|
cmdname -type string |
||||||
|
cmdarg -type any -multiple 1 -optional 1 |
||||||
|
}] |
||||||
|
proc run {args} { |
||||||
|
#set_last_run_display [list] |
||||||
|
|
||||||
|
#set splitargs [get_run_opts $args] |
||||||
|
#set runopts [dict get $splitargs runopts] |
||||||
|
#set runoptslong [dict get $splitargs runoptslong] |
||||||
|
#set cmdargs [dict get $splitargs cmdargs] |
||||||
|
set argd [punk::args::parse $args withid ::shellrun::run] |
||||||
|
lassign [dict values $argd] leaders opts values received |
||||||
|
|
||||||
|
if {[dict exists $received "-nonewline"]} { |
||||||
|
set nonewline 1 |
||||||
|
} else { |
||||||
|
set nonewline 0 |
||||||
|
} |
||||||
|
#review nonewline does nothing here.. |
||||||
|
|
||||||
|
set idlist_stderr [list] |
||||||
|
#we leave stdout without imposed ansi colouring - because the source may be colourised and because ansi-wrapping a stream at whatever boundaries it comes in at isn't a really nice thing to do. |
||||||
|
#stderr might have source colouring - but it usually doesn't seem to, and the visual distiction of red stderr can be very handy for the run command. |
||||||
|
#A further enhancement could be to detect well-known options such as --color and/or use a configuration for specific commands that have useful colourised stderr, |
||||||
|
#but having an option to configure stderr to red is a compromise. |
||||||
|
#Note that the other run commands, runout,runerr, runx don't emit in real-time - so for those commands there may be options to detect and/or post-process stdout and stderr. |
||||||
|
#TODO - fix. This has no effect if/when the repl adds an ansiwrap transform |
||||||
|
# what we probably want to do is 'aside' that transform for runxxx commands only. |
||||||
|
#lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] |
||||||
|
|
||||||
|
set callopts [dict create] |
||||||
|
if {[dict exists $received "-tcl"]} { |
||||||
|
dict set callopts -tclscript 1 |
||||||
|
} |
||||||
|
if {[dict exists $received "-debug"]} { |
||||||
|
dict set callopts -debug 1 |
||||||
|
} |
||||||
|
if {[dict exists $received --timeout]} { |
||||||
|
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||||
|
} |
||||||
|
set cmdname [dict get $values cmdname] |
||||||
|
if {[dict exists $received cmdarg]} { |
||||||
|
set cmdarglist [dict get $values cmdarg] |
||||||
|
} else { |
||||||
|
set cmdarglist {} |
||||||
|
} |
||||||
|
set cmdargs [concat $cmdname $cmdarglist] |
||||||
|
#--------------------------------------------------------------------------------------------- |
||||||
|
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] |
||||||
|
#--------------------------------------------------------------------------------------------- |
||||||
|
foreach id $idlist_stderr { |
||||||
|
shellfilter::stack::remove stderr $id |
||||||
|
} |
||||||
|
#puts stderr "shellrun::run exitinfo: $exitinfo" |
||||||
|
|
||||||
|
flush stderr |
||||||
|
flush stdout |
||||||
|
|
||||||
|
if {[dict exists $exitinfo error]} { |
||||||
|
error "[dict get $exitinfo error]\n$exitinfo" |
||||||
|
} |
||||||
|
|
||||||
|
return $exitinfo |
||||||
|
} |
||||||
|
|
||||||
|
lappend PUNKARGS [list { |
||||||
|
@id -id ::shellrun::runconsole |
||||||
|
@leaders -min 0 -max 0 |
||||||
|
@opts |
||||||
|
@values -min 1 -max -1 |
||||||
|
cmdname -type string |
||||||
|
cmdarg -type any -multiple 1 -optional 1 |
||||||
|
}] |
||||||
|
#run in the way tcl unknown does - but without regard to auto_noexec |
||||||
|
proc runconsole {args} { |
||||||
|
set argd [punk::args::parse $args withid ::shellrun::runconsole] |
||||||
|
lassign [dict values $argd] leaders opts values received |
||||||
|
set cmdname [dict get $values cmdname] |
||||||
|
if {[dict exists $received cmdarg]} { |
||||||
|
set arglist [dict get $values cmdarg] |
||||||
|
} else { |
||||||
|
set arglist {} |
||||||
|
} |
||||||
|
|
||||||
|
set resolved_cmdname [auto_execok $cmdname] |
||||||
|
if {$resolved_cmdname eq ""} { |
||||||
|
error "Cannot find path for executable '$cmdname'" |
||||||
|
} |
||||||
|
set repl_runid [punk::get_repl_runid] |
||||||
|
#set ::punk::last_run_display [list] |
||||||
|
|
||||||
|
set redir ">&@stdout <@stdin" |
||||||
|
uplevel 1 [list ::catch [concat exec $redir $resolved_cmdname $arglist] ::tcl::UnknownResult ::tcl::UnknownOptions] |
||||||
|
#we can't detect stdout/stderr output from the exec |
||||||
|
#for now emit an extra \n on stderr |
||||||
|
#todo - there is probably no way around this but to somehow exec in the context of a completely separate console |
||||||
|
#This is probably a tricky problem - especially to do cross-platform |
||||||
|
# |
||||||
|
# - use [dict get $::tcl::UnknownOptions -code] (0|1) exit |
||||||
|
if {[dict get $::tcl::UnknownOptions -code] == 0} { |
||||||
|
set c green |
||||||
|
set m "ok" |
||||||
|
} else { |
||||||
|
set c yellow |
||||||
|
set m "errorCode $::errorCode" |
||||||
|
} |
||||||
|
set chunklist [list] |
||||||
|
lappend chunklist [list "info" "[a $c]$m[a] " ] |
||||||
|
if {$repl_runid != 0} { |
||||||
|
tsv::lappend repl runchunks-$repl_runid {*}$chunklist |
||||||
|
} |
||||||
|
|
||||||
|
dict incr ::tcl::UnknownOptions -level |
||||||
|
return -options $::tcl::UnknownOptions $::tcl::UnknownResult |
||||||
|
} |
||||||
|
lappend PUNKARGS [list { |
||||||
|
@id -id ::shellrun::runout |
||||||
|
@leaders -min 0 -max 0 |
||||||
|
@opts |
||||||
|
-echo -type none |
||||||
|
-nonewline -type none |
||||||
|
-tcl -type none -default 0 |
||||||
|
-debug -type none -default 0 |
||||||
|
--timeout= -type integer |
||||||
|
@values -min 1 -max -1 |
||||||
|
cmdname -type string |
||||||
|
cmdarg -type any -multiple 1 -optional 1 |
||||||
|
}] |
||||||
|
proc runout {args} { |
||||||
|
set argd [punk::args::parse $args withid ::shellrun::runout] |
||||||
|
lassign [dict values $argd] leaders opts values received |
||||||
|
|
||||||
|
if {[dict exists $received "-nonewline"]} { |
||||||
|
set nonewline 1 |
||||||
|
} else { |
||||||
|
set nonewline 0 |
||||||
|
} |
||||||
|
|
||||||
|
#set_last_run_display [list] |
||||||
|
variable runout |
||||||
|
variable runerr |
||||||
|
set runout "" |
||||||
|
set runerr "" |
||||||
|
set RST [a] |
||||||
|
|
||||||
|
#set splitargs [get_run_opts $args] |
||||||
|
#set runopts [dict get $splitargs runopts] |
||||||
|
#set cmdargs [dict get $splitargs cmdargs] |
||||||
|
|
||||||
|
|
||||||
|
#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 {[dict exists $received "-echo"]} { |
||||||
|
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}] |
||||||
|
} |
||||||
|
|
||||||
|
set callopts [dict create] |
||||||
|
if {[dict exists $received "-tcl"]} { |
||||||
|
dict set callopts -tclscript 1 |
||||||
|
} |
||||||
|
if {[dict exists $received "-debug"]} { |
||||||
|
dict set callopts -debug 1 |
||||||
|
} |
||||||
|
if {[dict exists $received --timeout]} { |
||||||
|
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||||
|
} |
||||||
|
set cmdname [dict get $values cmdname] |
||||||
|
if {[dict exists $received cmdarg]} { |
||||||
|
set cmdarglist [dict get $values cmdarg] |
||||||
|
} else { |
||||||
|
set cmdarglist {} |
||||||
|
} |
||||||
|
set cmdargs [concat $cmdname $cmdarglist] |
||||||
|
|
||||||
|
#shellfilter::run [lrange $args 1 end] -teehandle punksh -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler |
||||||
|
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -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]} { |
||||||
|
if {[dict exists $received "-tcl"]} { |
||||||
|
|
||||||
|
} else { |
||||||
|
#we must raise an error. |
||||||
|
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||||
|
# |
||||||
|
set msg "" |
||||||
|
append msg [dict get $exitinfo error] |
||||||
|
append msg "\n(add -tcl option to run as a tcl command/script instead of an external command)" |
||||||
|
error $msg |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set chunklist [list] |
||||||
|
|
||||||
|
#exitcode not part of return value for runout - colourcode appropriately |
||||||
|
set n $RST |
||||||
|
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 "info" "$c$exitinfo$n"] |
||||||
|
} elseif {[dict exists $exitinfo error]} { |
||||||
|
# -tcl (with error) |
||||||
|
set c [a+ yellow bold] |
||||||
|
lappend chunklist [list "info" "${c}error [dict get $exitinfo error]$n"] |
||||||
|
lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] |
||||||
|
#lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] |
||||||
|
lappend chunklist [list "info" errorInfo] |
||||||
|
lappend chunklist [list "stderr" [dict get $exitinfo errorInfo]] |
||||||
|
} else { |
||||||
|
# -tcl (without error) |
||||||
|
set c [a+ Green white bold] |
||||||
|
#lappend chunklist [list "info" "$c$exitinfo$n"] |
||||||
|
lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c \x1b\[m "" $exitinfo]] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set chunk "[a+ red bold]stderr$RST" |
||||||
|
lappend chunklist [list "info" $chunk] |
||||||
|
|
||||||
|
set chunk "" |
||||||
|
if {[string length $::shellrun::runerr]} { |
||||||
|
if {$nonewline} { |
||||||
|
set e [string trimright $::shellrun::runerr \r\n] |
||||||
|
} else { |
||||||
|
set e $::shellrun::runerr |
||||||
|
} |
||||||
|
#append chunk "[a+ red normal]$e$RST\n" |
||||||
|
append chunk "[a+ red normal]$e$RST" |
||||||
|
} |
||||||
|
lappend chunklist [list stderr $chunk] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
lappend chunklist [list "info" "[a+ white bold]stdout$RST"] |
||||||
|
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" |
||||||
|
} |
||||||
|
lappend chunklist [list result $chunk] |
||||||
|
|
||||||
|
|
||||||
|
#set_last_run_display $chunklist |
||||||
|
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||||
|
|
||||||
|
if {$nonewline} { |
||||||
|
return [string trimright $::shellrun::runout \r\n] |
||||||
|
} else { |
||||||
|
return $::shellrun::runout |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
lappend PUNKARGS [list { |
||||||
|
@id -id ::shellrun::runerr |
||||||
|
@leaders -min 0 -max 0 |
||||||
|
@opts |
||||||
|
-echo -type none |
||||||
|
-nonewline -type none |
||||||
|
-tcl -type none -default 0 |
||||||
|
-debug -type none -default 0 |
||||||
|
--timeout= -type integer |
||||||
|
@values -min 1 -max -1 |
||||||
|
cmdname -type string |
||||||
|
cmdarg -type any -multiple 1 -optional 1 |
||||||
|
}] |
||||||
|
proc runerr {args} { |
||||||
|
set argd [punk::args::parse $args withid ::shellrun::runerr] |
||||||
|
lassign [dict values $argd] leaders opts values received |
||||||
|
|
||||||
|
if {[dict exists $received "-nonewline"]} { |
||||||
|
set nonewline 1 |
||||||
|
} else { |
||||||
|
set nonewline 0 |
||||||
|
} |
||||||
|
|
||||||
|
#set_last_run_display [list] |
||||||
|
variable runout |
||||||
|
variable runerr |
||||||
|
set runout "" |
||||||
|
set runerr "" |
||||||
|
|
||||||
|
#set splitargs [get_run_opts $args] |
||||||
|
#set runopts [dict get $splitargs runopts] |
||||||
|
#set cmdargs [dict get $splitargs cmdargs] |
||||||
|
|
||||||
|
set callopts [dict create] |
||||||
|
if {[dict exists $received "-tcl"]} { |
||||||
|
dict set callopts -tclscript 1 |
||||||
|
} |
||||||
|
if {[dict exists $received "-debug"]} { |
||||||
|
dict set callopts -debug 1 |
||||||
|
} |
||||||
|
if {[dict exists $received --timeout]} { |
||||||
|
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||||
|
} |
||||||
|
set cmdname [dict get $values cmdname] |
||||||
|
if {[dict exists $received cmdarg]} { |
||||||
|
set cmdarglist [dict get $values cmdarg] |
||||||
|
} else { |
||||||
|
set cmdarglist {} |
||||||
|
} |
||||||
|
set cmdargs [concat $cmdname $cmdarglist] |
||||||
|
|
||||||
|
if {[dict exists $received "-tcl"]} { |
||||||
|
append callopts " -tclscript 1" |
||||||
|
} |
||||||
|
if {[dict exists $received "-echo"]} { |
||||||
|
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 {*}$callopts -teehandle punksh -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]} { |
||||||
|
if {[dict exists $received "-tcl"]} { |
||||||
|
|
||||||
|
} else { |
||||||
|
#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] |
||||||
|
} |
||||||
|
lappend chunklist [list "info" "$c$exitinfo$n"] |
||||||
|
} elseif {[dict exists $exitinfo error]} { |
||||||
|
# -tcl (with error) |
||||||
|
set c [a+ yellow bold] |
||||||
|
lappend chunklist [list "info" "error [dict get $exitinfo error]"] |
||||||
|
lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] |
||||||
|
lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] |
||||||
|
} else { |
||||||
|
# -tcl (without error) |
||||||
|
set c [a+ Green white bold] |
||||||
|
#lappend chunklist [list "info" "$c$exitinfo$n"] |
||||||
|
lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c "\x1b\[m" "" $exitinfo]] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
lappend chunklist [list "info" "[a+ white bold]stdout[a]"] |
||||||
|
set chunk "" |
||||||
|
if {[string length $::shellrun::runout]} { |
||||||
|
if {$nonewline} { |
||||||
|
set o [string trimright $::shellrun::runout \r\n] |
||||||
|
} else { |
||||||
|
set o $::shellrun::runout |
||||||
|
} |
||||||
|
append chunk "[a+ white normal]$o[a]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. |
||||||
|
} |
||||||
|
lappend chunklist [list stdout $chunk] |
||||||
|
|
||||||
|
|
||||||
|
#set c_stderr [punk::config] |
||||||
|
set chunk "[a+ red bold]stderr[a]" |
||||||
|
lappend chunklist [list "info" $chunk] |
||||||
|
|
||||||
|
set chunk "" |
||||||
|
if {[string length $::shellrun::runerr]} { |
||||||
|
if {$nonewline} { |
||||||
|
set e [string trimright $::shellrun::runerr \r\n] |
||||||
|
} else { |
||||||
|
set e $::shellrun::runerr |
||||||
|
} |
||||||
|
append chunk "$e" |
||||||
|
} |
||||||
|
lappend chunklist [list resulterr $chunk] |
||||||
|
|
||||||
|
|
||||||
|
#set_last_run_display $chunklist |
||||||
|
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||||
|
|
||||||
|
if {$nonewline} { |
||||||
|
return [string trimright $::shellrun::runerr \r\n] |
||||||
|
} |
||||||
|
return $::shellrun::runerr |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc runx {args} { |
||||||
|
#set_last_run_display [list] |
||||||
|
variable runout |
||||||
|
variable runerr |
||||||
|
set runout "" |
||||||
|
set runerr "" |
||||||
|
|
||||||
|
set splitargs [get_run_opts $args] |
||||||
|
set runopts [dict get $splitargs runopts] |
||||||
|
set cmdargs [dict get $splitargs cmdargs] |
||||||
|
|
||||||
|
if {"-nonewline" in $runopts} { |
||||||
|
set nonewline 1 |
||||||
|
} else { |
||||||
|
set nonewline 0 |
||||||
|
} |
||||||
|
|
||||||
|
#shellfilter::stack::remove stdout $::repl::id_outstack |
||||||
|
|
||||||
|
if {"-echo" in $runopts} { |
||||||
|
#float to ensure repl transform doesn't interfere with the output data |
||||||
|
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float -settings {-varname ::shellrun::runerr}] |
||||||
|
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float -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 callopts "" |
||||||
|
if {"-tcl" in $runopts} { |
||||||
|
append callopts " -tclscript 1" |
||||||
|
} |
||||||
|
#set exitinfo [shellfilter::run $cmdargs -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||||
|
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none] |
||||||
|
|
||||||
|
shellfilter::stack::remove stdout $stdout_stackid |
||||||
|
shellfilter::stack::remove stderr $stderr_stackid |
||||||
|
|
||||||
|
|
||||||
|
flush stderr |
||||||
|
flush stdout |
||||||
|
|
||||||
|
if {[dict exists $exitinfo error]} { |
||||||
|
if {"-tcl" in $runopts} { |
||||||
|
|
||||||
|
} else { |
||||||
|
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||||
|
error [dict get $exitinfo error] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] |
||||||
|
|
||||||
|
set chunk "" |
||||||
|
if {[string length $::shellrun::runout]} { |
||||||
|
if {$nonewline} { |
||||||
|
set o [string trimright $::shellrun::runout \r\n] |
||||||
|
} else { |
||||||
|
set o $::shellrun::runout |
||||||
|
} |
||||||
|
set chunk $o |
||||||
|
} |
||||||
|
set chunklist [list] |
||||||
|
lappend chunklist [list "info" " "] |
||||||
|
lappend chunklist [list "result" stdout] ;#key 'stdout' forms part of the resulting dictionary output |
||||||
|
lappend chunklist [list "info" "[a+ white bold]stdout[a]"] |
||||||
|
lappend chunklist [list result $chunk] ;#value corresponding to 'stdout' key in resulting dict |
||||||
|
|
||||||
|
|
||||||
|
lappend chunklist [list "info" " "] |
||||||
|
set chunk "[a+ red bold]stderr[a]" |
||||||
|
lappend chunklist [list "result" $chunk] |
||||||
|
lappend chunklist [list "info" stderr] |
||||||
|
|
||||||
|
set chunk "" |
||||||
|
if {[string length $::shellrun::runerr]} { |
||||||
|
if {$nonewline} { |
||||||
|
set e [string trimright $::shellrun::runerr \r\n] |
||||||
|
} else { |
||||||
|
set e $::shellrun::runerr |
||||||
|
} |
||||||
|
set chunk $e |
||||||
|
} |
||||||
|
#stderr is part of the result |
||||||
|
lappend chunklist [list "resulterr" $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+ yellow bold] |
||||||
|
} |
||||||
|
lappend chunklist [list "info" " "] |
||||||
|
lappend chunklist [list "result" exitcode] |
||||||
|
lappend chunklist [list "info" "exitcode $code"] |
||||||
|
lappend chunklist [list "result" "$c$code$n"] |
||||||
|
set exitdict [list exitcode $code] |
||||||
|
} elseif {[dict exists $exitinfo result]} { |
||||||
|
# presumably from a -tcl call |
||||||
|
set val [dict get $exitinfo result] |
||||||
|
lappend chunklist [list "info" " "] |
||||||
|
lappend chunklist [list "result" result] |
||||||
|
lappend chunklist [list "info" result] |
||||||
|
lappend chunklist [list "result" $val] |
||||||
|
set exitdict [list result $val] |
||||||
|
} elseif {[dict exists $exitinfo error]} { |
||||||
|
# -tcl call with error |
||||||
|
#set exitdict [dict create] |
||||||
|
lappend chunklist [list "info" " "] |
||||||
|
lappend chunklist [list "result" error] |
||||||
|
lappend chunklist [list "info" error] |
||||||
|
lappend chunklist [list "result" [dict get $exitinfo error]] |
||||||
|
|
||||||
|
lappend chunklist [list "info" " "] |
||||||
|
lappend chunklist [list "result" errorCode] |
||||||
|
lappend chunklist [list "info" errorCode] |
||||||
|
lappend chunklist [list "result" [dict get $exitinfo errorCode]] |
||||||
|
|
||||||
|
lappend chunklist [list "info" " "] |
||||||
|
lappend chunklist [list "result" errorInfo] |
||||||
|
lappend chunklist [list "info" errorInfo] |
||||||
|
lappend chunklist [list "result" [dict get $exitinfo errorInfo]] |
||||||
|
|
||||||
|
set exitdict $exitinfo |
||||||
|
} else { |
||||||
|
#review - if no exitcode or result. then what is it? |
||||||
|
lappend chunklist [list "info" exitinfo] |
||||||
|
set c [a+ yellow bold] |
||||||
|
lappend chunklist [list result "$c$exitinfo$n"] |
||||||
|
set exitdict [list exitinfo $exitinfo] |
||||||
|
} |
||||||
|
|
||||||
|
#set_last_run_display $chunklist |
||||||
|
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$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 {$nonewline} { |
||||||
|
return [list {*}$exitdict stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n]] |
||||||
|
} |
||||||
|
#always return exitinfo $code at beginning of dict (so that punk unknown can interpret the exit code as a unix-style bool if double evaluated) |
||||||
|
return [list {*}$exitdict stdout $::shellrun::runout stderr $::shellrun::runerr] |
||||||
|
} |
||||||
|
|
||||||
|
#an experiment |
||||||
|
# |
||||||
|
#run as raw string instead of tcl-list - no variable subst etc |
||||||
|
# |
||||||
|
#dummy repl_runraw that repl will intercept |
||||||
|
proc repl_runraw {args} { |
||||||
|
error "runraw: only available in repl as direct call - not from script" |
||||||
|
} |
||||||
|
#we can only call runraw with a single (presumably braced) string if we want to use it from both repl and tcl scripts (why? todo with unbalanced quotes/braces?) |
||||||
|
proc runraw {commandline} { |
||||||
|
#runraw fails as intended - because we can't bypass exec/open interference quoting :/ |
||||||
|
#set_last_run_display [list] |
||||||
|
variable runout |
||||||
|
variable runerr |
||||||
|
set runout "" |
||||||
|
set runerr "" |
||||||
|
|
||||||
|
#return [shellfilter::run [lrange $args 1 end] -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||||
|
puts stdout ">>runraw got: $commandline" |
||||||
|
|
||||||
|
#run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing |
||||||
|
#for consistency with other runxxx commands - we'll just consume it. (review) |
||||||
|
|
||||||
|
set reallyraw 1 |
||||||
|
if {$reallyraw} { |
||||||
|
set wordparts [regexp -inline -all {\S+} $commandline] |
||||||
|
set runwords $wordparts |
||||||
|
} else { |
||||||
|
#shell style args parsing not suitable for windows where we can't assume matched quotes etc. |
||||||
|
package require string::token::shell |
||||||
|
set parts [string token shell -indices -- $commandline] |
||||||
|
puts stdout ">>shellparts: $parts" |
||||||
|
set runwords [list] |
||||||
|
foreach p $parts { |
||||||
|
set ptype [lindex $p 0] |
||||||
|
set pval [lindex $p 3] |
||||||
|
if {$ptype eq "PLAIN"} { |
||||||
|
lappend runwords [lindex $p 3] |
||||||
|
} elseif {$ptype eq "D:QUOTED"} { |
||||||
|
set v {"} |
||||||
|
append v $pval |
||||||
|
append v {"} |
||||||
|
lappend runwords $v |
||||||
|
} elseif {$ptype eq "S:QUOTED"} { |
||||||
|
set v {'} |
||||||
|
append v $pval |
||||||
|
append v {'} |
||||||
|
lappend runwords $v |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
puts stdout ">>runraw runwords: $runwords" |
||||||
|
set runwords [lrange $runwords 1 end] |
||||||
|
|
||||||
|
puts stdout ">>runraw runwords: $runwords" |
||||||
|
#set args [lrange $args 1 end] |
||||||
|
#set runwords [lrange $wordparts 1 end] |
||||||
|
|
||||||
|
set known_runopts [list "-echo" "-e" "-terminal" "-t"] |
||||||
|
set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self |
||||||
|
set runopts [list] |
||||||
|
set cmdwords [list] |
||||||
|
set idx_first_cmdarg [lsearch -not $runwords "-*"] |
||||||
|
set runopts [lrange $runwords 0 $idx_first_cmdarg-1] |
||||||
|
set cmdwords [lrange $runwords $idx_first_cmdarg end] |
||||||
|
|
||||||
|
foreach o $runopts { |
||||||
|
if {$o ni $known_runopts} { |
||||||
|
error "runraw: Unknown runoption $o" |
||||||
|
} |
||||||
|
} |
||||||
|
set runopts [lmap o $runopts {dict get $aliases $o}] |
||||||
|
|
||||||
|
set cmd_as_string [join $cmdwords " "] |
||||||
|
puts stdout ">>cmd_as_string: $cmd_as_string" |
||||||
|
|
||||||
|
if {"-terminal" in $runopts} { |
||||||
|
#fake terminal using 'script' command. |
||||||
|
#not ideal: smushes stdout & stderr together amongst other problems |
||||||
|
set tcmd [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdwords] |
||||||
|
puts stdout ">>tcmd: $tcmd" |
||||||
|
set exitinfo [shellfilter::run $tcmd -teehandle punksh -inbuffering line -outbuffering none ] |
||||||
|
set exitinfo "exitcode not-implemented" |
||||||
|
} else { |
||||||
|
set exitinfo [shellfilter::run $cmdwords -teehandle punksh -inbuffering line -outbuffering none ] |
||||||
|
} |
||||||
|
|
||||||
|
if {[dict exists $exitinfo error]} { |
||||||
|
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||||
|
error [dict get $exitinfo error] |
||||||
|
} |
||||||
|
set code [dict get $exitinfo exitcode] |
||||||
|
if {$code == 0} { |
||||||
|
set c [a+ green] |
||||||
|
} else { |
||||||
|
set c [a+ white bold] |
||||||
|
} |
||||||
|
puts stderr $c |
||||||
|
return $exitinfo |
||||||
|
} |
||||||
|
|
||||||
|
proc sh_run {args} { |
||||||
|
set splitargs [get_run_opts $args] |
||||||
|
set runopts [dict get $splitargs runopts] |
||||||
|
set cmdargs [dict get $splitargs cmdargs] |
||||||
|
#e.g sh -c "ls -l *" |
||||||
|
#we pass cmdargs to sh -c as a list, not individually |
||||||
|
tailcall shellrun::run {*}$runopts sh -c $cmdargs |
||||||
|
} |
||||||
|
proc sh_runout {args} { |
||||||
|
set splitargs [get_run_opts $args] |
||||||
|
set runopts [dict get $splitargs runopts] |
||||||
|
set cmdargs [dict get $splitargs cmdargs] |
||||||
|
tailcall shellrun::runout {*}$runopts sh -c $cmdargs |
||||||
|
} |
||||||
|
proc sh_runerr {args} { |
||||||
|
set splitargs [get_run_opts $args] |
||||||
|
set runopts [dict get $splitargs runopts] |
||||||
|
set cmdargs [dict get $splitargs cmdargs] |
||||||
|
tailcall shellrun::runerr {*}$runopts sh -c $cmdargs |
||||||
|
} |
||||||
|
proc sh_runx {args} { |
||||||
|
set splitargs [get_run_opts $args] |
||||||
|
set runopts [dict get $splitargs runopts] |
||||||
|
set cmdargs [dict get $splitargs cmdargs] |
||||||
|
tailcall shellrun::runx {*}$runopts sh -c $cmdargs |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
namespace eval shellrun { |
||||||
|
interp alias {} run {} shellrun::run |
||||||
|
interp alias {} sh_run {} shellrun::sh_run |
||||||
|
interp alias {} runout {} shellrun::runout |
||||||
|
interp alias {} sh_runout {} shellrun::sh_runout |
||||||
|
interp alias {} runerr {} shellrun::runerr |
||||||
|
interp alias {} sh_runerr {} shellrun::sh_runerr |
||||||
|
interp alias {} runx {} shellrun::runx |
||||||
|
interp alias {} sh_runx {} shellrun::sh_runx |
||||||
|
|
||||||
|
interp alias {} runc {} shellrun::runconsole |
||||||
|
interp alias {} runraw {} shellrun::runraw |
||||||
|
|
||||||
|
|
||||||
|
#the shortened versions deliberately don't get pretty output from the repl |
||||||
|
interp alias {} r {} shellrun::run |
||||||
|
interp alias {} ro {} shellrun::runout |
||||||
|
interp alias {} re {} shellrun::runerr |
||||||
|
interp alias {} rx {} shellrun::runx |
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
namespace eval shellrun { |
||||||
|
proc test_cffi {} { |
||||||
|
package require test_cffi |
||||||
|
cffi::Wrapper create ::shellrun::kernel32 [file join $env(windir) system32 Kernel32.dll] |
||||||
|
::shellrun::kernel32 stdcall CreateProcessA |
||||||
|
#todo - stuff. |
||||||
|
return ::shellrun::kernel32 |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
namespace eval ::punk::args::register { |
||||||
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||||
|
lappend ::punk::args::register::NAMESPACES ::shellrun |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
package provide shellrun [namespace eval shellrun { |
||||||
|
variable version |
||||||
|
set version 0.1.2 |
||||||
|
}] |
||||||
Binary file not shown.
Binary file not shown.
Loading…
Reference in new issue