@ -4,7 +4,25 @@ package provide punk [namespace eval punk {
set version 0.1
}]
#Punk - where radical modification is a craft and anti-patterns are another exploratory tool for the Pattern Punk.
#Built on Tcl of course - because it's the most powerful piece of under-appreciated and alternate-thinking engineering you can plug into.
#repltelemetry cooperation with other packages such as shellrun
#Maintenance warning: shellrun expects repltelemetry_emmitters to exist if punk namespace exists
namespace eval punk {
variable repltelemetry_emmitters
#don't stomp.. even if something created this namespace in advance and is 'cooperating' a bit early
if {![info exists repltelemetry_emitters]} {
set repltelemetry_emmitters [list]
}
}
#globals... some minimal global var pollution
#punk's official silly test dictionary
set punk_testd [dict create \
a0 a0val \
b0 [dict create \
@ -12,30 +30,37 @@ set punk_testd [dict create \
b1 b0b1val \
c1 b0c1val \
d1 b0d1val \
]\
c0 [dict create \
a1 [dict create \
a2 c0a1a2val \
b2 c0a1b2val \
c2 c0a1c2val \
] \
b1 [dict create \
a2 [dict create \
a3 c0b1a2a3val \
b3 c0b1a2b3val \
] \
b2 [dict create \
a3 c0b1b2a3val \
b3 [dict create \
a4 c0b1b2b3a4 \
] \
c3 [dict create] \
] \
] \
c0 [dict create] \
d0 [dict create \
a1 [dict create \
a2 d0a1a2val \
b2 d0a1b2val \
c2 d0a1c2val \
] \
] \
b1 [dict create \
a2 [dict create \
a3 d0b1a2a3val \
b3 d0b1a2b3val \
] \
b2 [dict create \
a3 d0b1b2a3val \
bananas "in pyjamas" \
c3 [dict create \
po "in { }" \
b4 ""\
c4 "can go boom" \
] \
d3 [dict create \
a4 "-paper -cuts" \
] \
e3 [dict create] \
] \
] \
] \
]
#cooperative withe punk repl
#impolitely cooperative withe punk repl - todo - tone it down.
namespace eval ::repl {
variable running 0
}
@ -44,6 +69,7 @@ package require punk::config
namespace eval punk {
interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system
package require pattern
package require shellfilter
package require punkapp
package require funcl
package require control
@ -79,10 +105,11 @@ namespace eval punk {
debug header "dbg> "
variable last_run_display [list]
variable ansi _disabled 0
variable colour _disabled 0
variable ns_current "::"
#variable re_headvar1 {([a-zA-Z:@.(),]+?)(?![^(]*\))(,.*)*$}
proc ::punk::K {x y} { return $x}
proc ::punk::var {varname {= {}} args} {
@ -2504,7 +2531,11 @@ namespace eval punk {
set ptype [string index $positionspecatomic 0]
set index [string range $positionspecatomic 1 end]
set isint [string is integer -strict $index]
if {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} {
if {$index eq "."} {
#blocking insertion-spec - explicit instruction not to pass this var in.
#most useful as just /. or data/. somevar/. is equivalent to leaving out the somevar insertionspec
#do nothing - no script
} elseif {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} {
if {$ptype eq "@"} {
#compare position to *possibly updated* list - note use of $index > $datalen rather than $index+1 > $datalen - (we allow 'insertion' at end of list by numeric index)
if {$isint} {
@ -2682,17 +2713,18 @@ namespace eval punk {
}
debug.punk.pipe.rep {>> [rep_listname segmentargvals]} 4
set ns [uplevel 1 {namespace current}]
if {!$add_argsdata} {
debug.punk.pipe {APPLY1: (args not set; not a list) segment vars:$segmentargnames} 4
#puts stderr " script: $script"
#puts stderr " vals: $segmentargvals"
set evaluation [uplevel 1 [list apply [list $segmentargnames $script :: ] {*}$segmentargvals]]
set evaluation [uplevel 1 [list apply [list $segmentargnames $script $ns ] {*}$segmentargvals]]
} else {
debug.punk.pipe {APPLY2: (args is set)segment vars:$segmentargnames} 4
#puts stderr " script: $script"
#puts stderr " vals: $segmentargvals $argsdatalist"
#pipeline script context should be one below calling context - so upvar v v will work
set evaluation [uplevel 1 [list apply [list [concat $segmentargnames args] $script :: ] {*}$segmentargvals {*}$argsdatalist]]
set evaluation [uplevel 1 [list apply [list [concat $segmentargnames args] $script $ns ] {*}$segmentargvals {*}$argsdatalist]]
}
debug.punk.pipe.rep {script result, evaluation: [rep_listname evaluation]} 4
@ -3473,29 +3505,31 @@ namespace eval punk {
#https://metacpan.org/pod/Text::ANSI::Util
#(saves up all ansi color codes since previus color reset and replays the saved codes after our highlighting is done)
proc ansi+ {args} {
variable ansi _disabled
if {$ansi _disabled == 1} {
variable colour _disabled
if {$colour _disabled == 1} {
return
}
tailcall ::shellfilter::ansi::+ {*}$args
}
proc ansi {{onoff {}}} {
variable ansi_disabled
proc colour {{onoff {}}} {
variable colour_disabled
if {[string length $onoff]} {
set onoff [string tolower $onoff]
if {$onoff in [list 1 on true yes]} {
interp alias "" a+ "" punk::ansi+
set ansi _disabled 0
set colour _disabled 0
} elseif {$onoff in [list 0 off false no]} {
interp alias "" a+ "" control::no-op
set ansi _disabled 1
set colour _disabled 1
} else {
error "punk::ansi expected 0|1|on|off|true|false|yes|no"
error "punk::colour expected 0|1|on|off|true|false|yes|no"
}
}
catch {repl::reset_prompt}
return [expr {!$ansi _disabled}]
return [expr {!$colour _disabled}]
}
proc scriptlibpath {{shortname {}} args} {
upvar ::punk::config::running running_config
set scriptlib [dict get $running_config scriptlib]
@ -3955,7 +3989,7 @@ namespace eval punk {
set fqpath $ns_current
}
}
puts stderr ">>fqpath $fqpath"
# puts stderr ">>fqpath $fqpath"
set nstail [namespace tail $glob]
if {[string first ? $nstail] >= 0 || [string first * $nstail] >=0} {
set location $fqpath
@ -4176,6 +4210,11 @@ namespace eval punk {
}
set is_absolute [string match ::* $a1]
if {$is_absolute} {
if {![llength $atail] && ([string first * [namespace tail $a1]] >= 0 || [string first ? [namespace tail $a1]] >= 0)} {
set out [punk::nslist $a1]
append out "\n$a1"
return $out
}
if {[namespace exists $a1]} {
set ns_current $a1
tailcall punk::ns/ {*}$atail
@ -4187,6 +4226,13 @@ namespace eval punk {
} else {
set nsnext ${ns_current}::$a1
}
if {![llength $atail] && ([string first * [namespace tail $a1]] >= 0)} {
set out [punk::nslist $nsnext]
append out "\n$nsnext"
return $out
}
if {[namespace exists $nsnext]} {
set ns_current $nsnext
tailcall punk::ns/ {*}$atail
@ -4801,7 +4847,8 @@ namespace eval punk {
interp alias {} hide {} punkapp::hide_console ;#will only work if controllable toplevels exist
interp alias {} ansi {} punk::ansi
interp alias {} colour {} punk::colour
interp alias {} color {} punk::colour
interp alias {} a+ {} punk::ansi+
#sh style 'test' and 'exitcode' (0 is false)
@ -4947,28 +4994,108 @@ namespace eval punk {
interp alias {} listset {} punk::listset ;#identical to pipeset
#experimental
#is there ever any difference to {namespace curent}?
interp alias {} nsthis {} .= .= namespace code {namespace current} |> .=* <0/#|
interp alias {} nsthis2 {} .= namespace current <0/#|
interp alias {} nscommands {} ,'ok'@0.= {
interp alias {} nscommands1 {} .= ,'ok'@0.= {
upvar caseresult caseresult
inspect -label namespace_current [namespace current]
inspect -label nsthis [nsthis]
inspect -label nsthis2 [nsthis2]
inspect -label commandns $commandns
inspect -label info_procs [info procs]
#by using pipeswitch instead of pipeswitchc - we give the ability* for the switch script block to affect vars in the calling scope
# (*not a desirable feature from a functional point of view - but useful for debugging, and also potentially faster )
pipeswitch {
#no glob chars present
if {![llength $ns]} {
set ns $commandns
} else {
if {![string match ::* $ns]} {
if {$commandns eq "::"} {set commandns ""}
set ns ${commandns}::$ns
}
}
inspect '$ns'
pipecase \
caseresult= $ns |input> \
1.= {expr {[string length [string map [list * "" ? ""] $data]] == [string length $data]}} |> {
uplevel #0 [list info commands ${input}::*]
#uplevel 1 [list info commands ${input}::*]
info commands ${input}::*
}
#pipecase1 ns has one or more of glob chars * or ?
pipecase \
caseresult= $ns |input> {
uplevel #0 [list info commands ${input}]
#uplevel 1 [list info commands ${input}]
info commands ${input}
}
}
} |data@@ok/result> {lmap v $data {namespace tail $v}} |> lsort |> {join $data \n} <ns/0|
interp alias {} nscommands {} .= ,'ok'@0.= {
upvar caseresult caseresult
#inspect -label namespace_current [namespace current]
#inspect -label info_procs [info procs]
set commandns [namespace current]
set commandlist [list]
#color code multiple args? - not very practical if many ns args supplied, but then... common case will only be 1 or 2 anyway
#colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed
set colors [list none cyan yellow green]
set ci 0 ;#colourindex
if {![llength $nslist]} {
lappend nslist *
}
foreach ns $nslist {
if {$ci > [llength $colors]-1} {
set ci 0
}
#by using pipeswitch instead of pipeswitchc - we give the ability* for the switch script block to affect vars in the calling scope
# (*not a desirable feature from a functional point of view - but useful for debugging, and also potentially faster )
if {$ci == 0} {
set col ""
} else {
set col [a+ [lindex $colors $ci] bold]
}
set matchedcommands [pipeswitch {
#no glob chars present
if {![llength $ns]} {
set ns $commandns
} else {
if {![string match ::* $ns]} {
if {$commandns eq "::"} {set commandns ""}
set ns ${commandns}::$ns
}
}
#inspect '$ns'
pipecase \
caseresult= $ns |input> \
1.= {expr {[string length [string map [list * "" ? ""] $data]] == [string length $data]}} |> {
#uplevel 1 [list info commands ${input}::*]
info commands ${input}::*
}
} |data@@ok/result> {lmap v $data {namespace tail $v}} |> lsort |> {join $data \n} <ns|
#pipecase1 ns has one or more of glob chars * or ?
pipecase \
caseresult= $ns |input> {
#uplevel 1 [list info commands ${input}]
info commands ${input}
}
}]
#lappend commandlist {*}[@@ok/result= $matchedcommands]
set rawcmds [@@ok/result= $matchedcommands |> {lmap v $data {namespace tail $v}}]
foreach c $rawcmds {
lappend commandlist [list $c $col$c[a+]]
#lappend commandlist $c
}
incr ci ;#colourindex
}
list ok [list result $commandlist]
} |data@@ok/result> lsort -index 0 |> {lmap v $data {lindex $v 1}} |> {join $data \n} <nslist|
#interp alias {} = {} ::punk::pipeline = "" ""
interp alias {} = {} ::punk::match_assign "" ""
@ -4978,13 +5105,6 @@ namespace eval punk {
# tailcall ::punk::pipeline .= "" "" {*}$args
#}
# new pipecommand syntax
proc =| {args} {
}
proc =/0| {args} {
}
