@ -4,7 +4,25 @@ package provide punk [namespace eval punk {
set version 0.1 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 #globals... some minimal global var pollution
#punk's official silly test dictionary
set punk_testd [dict create \ set punk_testd [dict create \
a0 a0val \ a0 a0val \
b0 [dict create \ b0 [dict create \
@ -12,30 +30,37 @@ set punk_testd [dict create \
b1 b0b1val \ b1 b0b1val \
c1 b0c1val \ c1 b0c1val \
d1 b0d1val \ d1 b0d1val \
]\ ] \
c0 [dict create \ c0 [dict create] \
d0 [dict create \
a1 [dict create \ a1 [dict create \
a2 c 0a1a2val \ a2 d 0a1a2val \
b2 c 0a1b2val \ b2 d 0a1b2val \
c2 c 0a1c2val \ c2 d 0a1c2val \
] \ ] \
b1 [dict create \ b1 [dict create \
a2 [dict create \ a2 [dict create \
a3 c 0b1a2a3val \ a3 d 0b1a2a3val \
b3 c 0b1a2b3val \ b3 d 0b1a2b3val \
] \ ] \
b2 [dict create \ b2 [dict create \
a3 c0b1b2a3val \ a3 d0b1b2a3val \
b3 [dict create \ bananas "in pyjamas" \
a4 c0b1b2b3a4 \ c3 [dict create \
po "in { }" \
b4 ""\
c4 "can go boom" \
] \ ] \
c3 [dict create] \ 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 { namespace eval ::repl {
variable running 0 variable running 0
} }
@ -44,6 +69,7 @@ package require punk::config
namespace eval punk { namespace eval punk {
interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system
package require pattern package require pattern
package require shellfilter
package require punkapp package require punkapp
package require funcl package require funcl
package require control package require control
@ -79,10 +105,11 @@ namespace eval punk {
debug header "dbg> " debug header "dbg> "
variable last_run_display [list] variable last_run_display [list]
variable ansi _disabled 0 variable colour _disabled 0
variable ns_current "::" variable ns_current "::"
#variable re_headvar1 {([a-zA-Z:@.(),]+?)(?![^(]*\))(,.*)*$} #variable re_headvar1 {([a-zA-Z:@.(),]+?)(?![^(]*\))(,.*)*$}
proc ::punk::K {x y} { return $x} proc ::punk::K {x y} { return $x}
proc ::punk::var {varname {= {}} args} { proc ::punk::var {varname {= {}} args} {
@ -2504,7 +2531,11 @@ namespace eval punk {
set ptype [string index $positionspecatomic 0] set ptype [string index $positionspecatomic 0]
set index [string range $positionspecatomic 1 end] set index [string range $positionspecatomic 1 end]
set isint [string is integer -strict $index] 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 "@"} { 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) #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} { if {$isint} {
@ -2682,17 +2713,18 @@ namespace eval punk {
} }
debug.punk.pipe.rep {>> [rep_listname segmentargvals]} 4 debug.punk.pipe.rep {>> [rep_listname segmentargvals]} 4
set ns [uplevel 1 {namespace current}]
if {!$add_argsdata} { if {!$add_argsdata} {
debug.punk.pipe {APPLY1: (args not set; not a list) segment vars:$segmentargnames} 4 debug.punk.pipe {APPLY1: (args not set; not a list) segment vars:$segmentargnames} 4
#puts stderr " script: $script" #puts stderr " script: $script"
#puts stderr " vals: $segmentargvals" #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 { } else {
debug.punk.pipe {APPLY2: (args is set)segment vars:$segmentargnames} 4 debug.punk.pipe {APPLY2: (args is set)segment vars:$segmentargnames} 4
#puts stderr " script: $script" #puts stderr " script: $script"
#puts stderr " vals: $segmentargvals $argsdatalist" #puts stderr " vals: $segmentargvals $argsdatalist"
#pipeline script context should be one below calling context - so upvar v v will work #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 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 #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) #(saves up all ansi color codes since previus color reset and replays the saved codes after our highlighting is done)
proc ansi+ {args} { proc ansi+ {args} {
variable ansi _disabled variable colour _disabled
if {$ansi _disabled == 1} { if {$colour _disabled == 1} {
return return
} }
tailcall ::shellfilter::ansi::+ {*}$args tailcall ::shellfilter::ansi::+ {*}$args
} }
proc ansi {{onoff {}}} {
variable ansi_disabled proc colour {{onoff {}}} {
variable colour_disabled
if {[string length $onoff]} { if {[string length $onoff]} {
set onoff [string tolower $onoff] set onoff [string tolower $onoff]
if {$onoff in [list 1 on true yes]} { if {$onoff in [list 1 on true yes]} {
interp alias "" a+ "" punk::ansi+ interp alias "" a+ "" punk::ansi+
set ansi _disabled 0 set colour _disabled 0
} elseif {$onoff in [list 0 off false no]} { } elseif {$onoff in [list 0 off false no]} {
interp alias "" a+ "" control::no-op interp alias "" a+ "" control::no-op
set ansi _disabled 1 set colour _disabled 1
} else { } 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} catch {repl::reset_prompt}
return [expr {!$ansi _disabled}] return [expr {!$colour _disabled}]
} }
proc scriptlibpath {{shortname {}} args} { proc scriptlibpath {{shortname {}} args} {
upvar ::punk::config::running running_config upvar ::punk::config::running running_config
set scriptlib [dict get $running_config scriptlib] set scriptlib [dict get $running_config scriptlib]
@ -3955,7 +3989,7 @@ namespace eval punk {
set fqpath $ns_current set fqpath $ns_current
} }
} }
puts stderr ">>fqpath $fqpath" # puts stderr ">>fqpath $fqpath"
set nstail [namespace tail $glob] set nstail [namespace tail $glob]
if {[string first ? $nstail] >= 0 || [string first * $nstail] >=0} { if {[string first ? $nstail] >= 0 || [string first * $nstail] >=0} {
set location $fqpath set location $fqpath
@ -4176,6 +4210,11 @@ namespace eval punk {
} }
set is_absolute [string match ::* $a1] set is_absolute [string match ::* $a1]
if {$is_absolute} { 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]} { if {[namespace exists $a1]} {
set ns_current $a1 set ns_current $a1
tailcall punk::ns/ {*}$atail tailcall punk::ns/ {*}$atail
@ -4187,6 +4226,13 @@ namespace eval punk {
} else { } else {
set nsnext ${ns_current}::$a1 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]} { if {[namespace exists $nsnext]} {
set ns_current $nsnext set ns_current $nsnext
tailcall punk::ns/ {*}$atail 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 {} 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+ interp alias {} a+ {} punk::ansi+
#sh style 'test' and 'exitcode' (0 is false) #sh style 'test' and 'exitcode' (0 is false)
@ -4947,28 +4994,108 @@ namespace eval punk {
interp alias {} listset {} punk::listset ;#identical to pipeset 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 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 #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 ) # (*not a desirable feature from a functional point of view - but useful for debugging, and also potentially faster )
pipeswitch { pipeswitch {
#no glob chars present #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 \ pipecase \
caseresult= $ns |input> \ caseresult= $ns |input> \
1.= {expr {[string length [string map [list * "" ? ""] $data]] == [string length $data]}} |> { 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 ? #pipecase1 ns has one or more of glob chars * or ?
pipecase \ pipecase \
caseresult= $ns |input> { 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::pipeline = "" ""
interp alias {} = {} ::punk::match_assign "" "" interp alias {} = {} ::punk::match_assign "" ""
@ -4978,13 +5105,6 @@ namespace eval punk {
# tailcall ::punk::pipeline .= "" "" {*}$args # tailcall ::punk::pipeline .= "" "" {*}$args
#} #}
# new pipecommand syntax
proc =| {args} {
}
proc =/0| {args} {
}
