6 changed files with 4640 additions and 4640 deletions
@ -1,157 +1,157 @@
|
||||
|
||||
package provide [lassign {overtype 1.3} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $ver[set ver {}]]$version}] |
||||
|
||||
#Julian Noble <julian@precisium.com.au> - 2003 |
||||
#Released under standard 'BSD license' conditions. |
||||
# |
||||
#todo - ellipsis truncation indicator for center,right |
||||
|
||||
|
||||
namespace eval overtype { |
||||
namespace export * |
||||
} |
||||
proc overtype::about {} { |
||||
return "Simple text formatting. Author JMN. BSD-License" |
||||
} |
||||
|
||||
|
||||
proc overtype::left {args} { |
||||
# @c overtype starting at left (overstrike) |
||||
# @c can/should we use something like this?: 'format "%-*s" $len $overtext |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-ellipsis) 0 |
||||
set opt(-ellipsistext) {...} |
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set len [string length $undertext] |
||||
set overlen [string length $overtext] |
||||
set diff [expr {$overlen - $len}] |
||||
if {$diff > 0} { |
||||
if {$opt(-overflow)} { |
||||
return $overtext |
||||
} else { |
||||
if {$opt(-ellipsis)} { |
||||
return [overtype::right [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] |
||||
} else { |
||||
return [string range $overtext 0 [expr {$len -1}]] |
||||
} |
||||
} |
||||
} else { |
||||
|
||||
return "$overtext[string range $undertext $overlen end]" |
||||
} |
||||
} |
||||
|
||||
# test - use more tcl8.5 features. |
||||
proc overtype::left2 {args} { |
||||
# @c overtype starting at left (overstrike) |
||||
# @c can/should we use something like this?: 'format "%-*s" $len $overtext |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-ellipsis) 0 |
||||
set opt(-ellipsistext) {...} |
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set len [string length $undertext] |
||||
set overlen [string length $overtext] |
||||
set diff [expr {$overlen - $len}] |
||||
if {$diff > 0} { |
||||
if {$opt(-overflow)} { |
||||
return $overtext |
||||
} else { |
||||
if {$opt(-ellipsis)} { |
||||
return [overtype::right [string range $overtext 0 $len-1] $opt(-ellipsistext)] |
||||
} else { |
||||
return [string range $overtext 0 $len-1 ] |
||||
} |
||||
} |
||||
} else { |
||||
#return "$overtext[string range $undertext $overlen end]" |
||||
return [string replace $undertext 0 $overlen-1 $overtext] |
||||
} |
||||
} |
||||
proc overtype::centre {args} { |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-bias) left |
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set olen [string length $overtext] |
||||
set ulen [string length $undertext] |
||||
set diff [expr {$ulen - $olen}] |
||||
if {$diff > 0} { |
||||
set half [expr {round(int($diff / 2))}] |
||||
if {[string match right $opt(-bias)]} { |
||||
if {[expr {2 * $half}] < $diff} { |
||||
incr half |
||||
} |
||||
} |
||||
|
||||
set rhs [expr {$diff - $half - 1}] |
||||
set lhs [expr {$half - 1}] |
||||
|
||||
set a [string range $undertext 0 $lhs] |
||||
set b $overtext |
||||
set c [string range $undertext end-$rhs end] |
||||
return $a$b$c |
||||
} else { |
||||
if {$diff < 0} { |
||||
if {$opt(-overflow)} { |
||||
return $overtext |
||||
} else { |
||||
return [string range $overtext 0 [expr {$ulen - 1}]] |
||||
} |
||||
} else { |
||||
return $overtext |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc overtype::right {args} { |
||||
# @d !todo - implement overflow, length checks etc |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set olen [string length $overtext] |
||||
set ulen [string length $undertext] |
||||
|
||||
if {$opt(-overflow)} { |
||||
return [string range $undertext 0 end-$olen]$overtext |
||||
} else { |
||||
if {$olen > $ulen} { |
||||
set diff [expr {$olen - $ulen}] |
||||
return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] |
||||
} else { |
||||
return [string range $undertext 0 end-$olen]$overtext |
||||
} |
||||
} |
||||
} |
||||
|
||||
namespace eval overtype { |
||||
interp alias {} ::overtype::center {} ::overtype::centre |
||||
} |
||||
|
||||
package provide [lassign {overtype 1.3} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $ver[set ver {}]]$version}] |
||||
|
||||
#Julian Noble <julian@precisium.com.au> - 2003 |
||||
#Released under standard 'BSD license' conditions. |
||||
# |
||||
#todo - ellipsis truncation indicator for center,right |
||||
|
||||
|
||||
namespace eval overtype { |
||||
namespace export * |
||||
} |
||||
proc overtype::about {} { |
||||
return "Simple text formatting. Author JMN. BSD-License" |
||||
} |
||||
|
||||
|
||||
proc overtype::left {args} { |
||||
# @c overtype starting at left (overstrike) |
||||
# @c can/should we use something like this?: 'format "%-*s" $len $overtext |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-ellipsis) 0 |
||||
set opt(-ellipsistext) {...} |
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set len [string length $undertext] |
||||
set overlen [string length $overtext] |
||||
set diff [expr {$overlen - $len}] |
||||
if {$diff > 0} { |
||||
if {$opt(-overflow)} { |
||||
return $overtext |
||||
} else { |
||||
if {$opt(-ellipsis)} { |
||||
return [overtype::right [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] |
||||
} else { |
||||
return [string range $overtext 0 [expr {$len -1}]] |
||||
} |
||||
} |
||||
} else { |
||||
|
||||
return "$overtext[string range $undertext $overlen end]" |
||||
} |
||||
} |
||||
|
||||
# test - use more tcl8.5 features. |
||||
proc overtype::left2 {args} { |
||||
# @c overtype starting at left (overstrike) |
||||
# @c can/should we use something like this?: 'format "%-*s" $len $overtext |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-ellipsis) 0 |
||||
set opt(-ellipsistext) {...} |
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set len [string length $undertext] |
||||
set overlen [string length $overtext] |
||||
set diff [expr {$overlen - $len}] |
||||
if {$diff > 0} { |
||||
if {$opt(-overflow)} { |
||||
return $overtext |
||||
} else { |
||||
if {$opt(-ellipsis)} { |
||||
return [overtype::right [string range $overtext 0 $len-1] $opt(-ellipsistext)] |
||||
} else { |
||||
return [string range $overtext 0 $len-1 ] |
||||
} |
||||
} |
||||
} else { |
||||
#return "$overtext[string range $undertext $overlen end]" |
||||
return [string replace $undertext 0 $overlen-1 $overtext] |
||||
} |
||||
} |
||||
proc overtype::centre {args} { |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-bias) left |
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set olen [string length $overtext] |
||||
set ulen [string length $undertext] |
||||
set diff [expr {$ulen - $olen}] |
||||
if {$diff > 0} { |
||||
set half [expr {round(int($diff / 2))}] |
||||
if {[string match right $opt(-bias)]} { |
||||
if {[expr {2 * $half}] < $diff} { |
||||
incr half |
||||
} |
||||
} |
||||
|
||||
set rhs [expr {$diff - $half - 1}] |
||||
set lhs [expr {$half - 1}] |
||||
|
||||
set a [string range $undertext 0 $lhs] |
||||
set b $overtext |
||||
set c [string range $undertext end-$rhs end] |
||||
return $a$b$c |
||||
} else { |
||||
if {$diff < 0} { |
||||
if {$opt(-overflow)} { |
||||
return $overtext |
||||
} else { |
||||
return [string range $overtext 0 [expr {$ulen - 1}]] |
||||
} |
||||
} else { |
||||
return $overtext |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc overtype::right {args} { |
||||
# @d !todo - implement overflow, length checks etc |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set olen [string length $overtext] |
||||
set ulen [string length $undertext] |
||||
|
||||
if {$opt(-overflow)} { |
||||
return [string range $undertext 0 end-$olen]$overtext |
||||
} else { |
||||
if {$olen > $ulen} { |
||||
set diff [expr {$olen - $ulen}] |
||||
return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] |
||||
} else { |
||||
return [string range $undertext 0 end-$olen]$overtext |
||||
} |
||||
} |
||||
} |
||||
|
||||
namespace eval overtype { |
||||
interp alias {} ::overtype::center {} ::overtype::centre |
||||
} |
||||
|
||||
@ -1,265 +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> |
||||
|
||||
#<?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> |
||||
|
||||
|
||||
@ -1,388 +1,388 @@
|
||||
# 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 "[a+ red light]$e[a+]\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 "[a+ white light]$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 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 |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
#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 chunklist [list] |
||||
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 |
||||
} |
||||
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 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 {$nonewline} { |
||||
return [list stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n] {*}$exitinfo] |
||||
} |
||||
#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 {*}$exitinfo stdout $::shellrun::runout stderr $::shellrun::runerr] |
||||
} |
||||
} |
||||
# 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 "[a+ red light]$e[a+]\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 "[a+ white light]$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 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 |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
#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 chunklist [list] |
||||
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 |
||||
} |
||||
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 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 {$nonewline} { |
||||
return [list stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n] {*}$exitinfo] |
||||
} |
||||
#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 {*}$exitinfo stdout $::shellrun::runout stderr $::shellrun::runerr] |
||||
} |
||||
} |
||||
|
||||
Loading…
Reference in new issue