25 changed files with 6028 additions and 2389 deletions
@ -0,0 +1,376 @@ |
|||||||
|
package provide punk::lib [namespace eval punk::lib { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
}] |
||||||
|
|
||||||
|
namespace eval punk::lib { |
||||||
|
>pattern .. Create >libpattern ;#clone to a library factory |
||||||
|
>libpattern .. Construct {args} { |
||||||
|
var o_this |
||||||
|
set o_this @this@ |
||||||
|
var o_last_child |
||||||
|
set o_last_child "" |
||||||
|
} |
||||||
|
|
||||||
|
>libpattern .. Method version {} { |
||||||
|
return 1.0.0 |
||||||
|
} |
||||||
|
|
||||||
|
>libpattern .. Method aliasprefix {pfx} { |
||||||
|
var o_this |
||||||
|
var o_last_child |
||||||
|
if {![string length $o_last_child]} { |
||||||
|
error " . aliasprefix - Create library object with . new >somename first." |
||||||
|
} |
||||||
|
set patternmethods [$o_this .. PM] |
||||||
|
set aliases [list] |
||||||
|
foreach m $patternmethods { |
||||||
|
set a ${pfx}${m} |
||||||
|
if {[llength [info commands $a]]} { |
||||||
|
puts stderr "WARNING - a command was already present at: $a" |
||||||
|
} |
||||||
|
interp alias "" $a "" [$o_last_child . $m .] |
||||||
|
lappend aliases $a |
||||||
|
} |
||||||
|
return $aliases |
||||||
|
} |
||||||
|
>libpattern .. Method new {objcmdname} { |
||||||
|
var o_this |
||||||
|
set o_this @this@ |
||||||
|
var o_last_child |
||||||
|
set nscaller [uplevel 1 [list namespace current]] |
||||||
|
if {![string match ::* $objcmdname]} { |
||||||
|
if {$nscaller eq "::"} {set nscaller ""} |
||||||
|
set objcmdname ${nscaller}::$objcmdname |
||||||
|
} |
||||||
|
uplevel 1 [list $o_this .. Create $objcmdname] |
||||||
|
set o_last_child $objcmdname |
||||||
|
} |
||||||
|
|
||||||
|
>libpattern .. Constructor {args} { |
||||||
|
var o_this |
||||||
|
set o_this @this@ |
||||||
|
} |
||||||
|
|
||||||
|
>libpattern .. Clone >ls_lib |
||||||
|
>ls_lib .. PatternMethod tail {args} { |
||||||
|
if {![llength $args]} { |
||||||
|
error "argumenterror cannot retrieve tail on an empty input list" ">ls_lib . tail $args" [list argumenterror tail empty_list] |
||||||
|
} |
||||||
|
lrange $args 1 end |
||||||
|
} |
||||||
|
>ls_lib .. PatternMethod init {args} { |
||||||
|
if {![llength $args]} { |
||||||
|
error "argumenterror cannot retrieve init on an empty input list" ">ls_lib . init $args" [list argumenterror init empty_list] |
||||||
|
} |
||||||
|
lrange $args 0 end-1 |
||||||
|
} |
||||||
|
>ls_lib .. PatternMethod head {args} { |
||||||
|
if {![llength $args]} { |
||||||
|
error "argumenterror cannot retrieve head on an empty input list" ">ls_lib . head $args" [list argumenterror head empty_list] |
||||||
|
} |
||||||
|
lindex $args 0 |
||||||
|
} |
||||||
|
>ls_lib .. PatternMethod last {args} { |
||||||
|
if {![llength $args]} { |
||||||
|
error "argumenterror cannot retrieve last on an empty input list. Use li.index end to avoid list length check" ">ls_lib . last $args" [list argumenterror last empty_list] |
||||||
|
} |
||||||
|
lindex $args end |
||||||
|
} |
||||||
|
>ls_lib .. PatternMethod elem {val args} { |
||||||
|
expr {$val in $args} |
||||||
|
} |
||||||
|
>ls_lib .. PatternMethod index {idx args} { |
||||||
|
lindex $args $idx |
||||||
|
} |
||||||
|
>ls_lib .. PatternMethod range {s e args} { |
||||||
|
lrange $args $s $e |
||||||
|
} |
||||||
|
|
||||||
|
#take/drop - haskell-like - but no lazy support REVIEW |
||||||
|
#see also https://www.haskellforall.com/2022/05/why-does-haskells-take-function-accept.html |
||||||
|
>ls_lib .. PatternMethod take {n args} { |
||||||
|
#keep basic behaviour like Haskell ie we allow returning less than n (without error) if insufficient elements |
||||||
|
lrange $args 0 $n-1 |
||||||
|
} |
||||||
|
>ls_lib .. PatternMethod drop {n args} { |
||||||
|
lrange $args $n end |
||||||
|
} |
||||||
|
|
||||||
|
>ls_lib . new >ls |
||||||
|
>ls_lib . aliasprefix "ls." |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#list item lib |
||||||
|
>libpattern .. Clone >li_lib |
||||||
|
>li_lib .. PatternMethod tail {listdata} { |
||||||
|
if {![llength $listdata]} { |
||||||
|
error "argumenterror cannot retrieve tail on an empty input list" ">li_lib . tail $listdata" [list argumenterror tail empty_list] |
||||||
|
} |
||||||
|
lrange $listdata 1 end |
||||||
|
} |
||||||
|
>li_lib .. PatternMethod init {listdata} { |
||||||
|
if {![llength $listdata]} { |
||||||
|
error "argumenterror cannot retrieve init on an empty input list" ">li_lib . init $listdata" [list argumenterror init empty_list] |
||||||
|
} |
||||||
|
lrange $listdata 0 end-1 |
||||||
|
} |
||||||
|
>li_lib .. PatternMethod head {listdata} { |
||||||
|
if {![llength $listdata]} { |
||||||
|
error "argumenterror cannot retrieve head on an empty input list" ">li_lib . head $listdata" [list argumenterror head empty_list] |
||||||
|
} |
||||||
|
lindex $listdata 0 |
||||||
|
} |
||||||
|
>li_lib .. PatternMethod last {listdata} { |
||||||
|
if {![llength $listdata]} { |
||||||
|
error "argumenterror cannot retrieve last on an empty input list. Use li.index end to avoid list length check" ">li_lib . last $listdata" [list argumenterror last empty_list] |
||||||
|
} |
||||||
|
lindex $listdata end |
||||||
|
} |
||||||
|
>li_lib .. PatternMethod elem {val listdata} { |
||||||
|
expr {$val in $listdata} |
||||||
|
} |
||||||
|
>li_lib .. PatternMethod index {idx listdata} { |
||||||
|
lindex $listdata $idx |
||||||
|
} |
||||||
|
>li_lib .. PatternMethod range {s e listdata} { |
||||||
|
lrange $listdata $s $e |
||||||
|
} |
||||||
|
|
||||||
|
#take/drop - haskell-like - but no lazy support REVIEW |
||||||
|
#see also https://www.haskellforall.com/2022/05/why-does-haskells-take-function-accept.html |
||||||
|
>li_lib .. PatternMethod take {n listdata} { |
||||||
|
#keep basic behaviour like Haskell ie we allow returning less than n (without error) if insufficient elements |
||||||
|
lrange $listdata 0 $n-1 |
||||||
|
} |
||||||
|
>li_lib .. PatternMethod drop {n listdata} { |
||||||
|
lrange $listdata $n end |
||||||
|
} |
||||||
|
#todo - takeWhile, dropWhile, takeWhileEnd, dropWhileEnd |
||||||
|
|
||||||
|
>li_lib .. PatternMethod is_list_all_in_list {a b} { |
||||||
|
package require struct::list |
||||||
|
package require struct::set |
||||||
|
set a_in_b [lsort [struct::set intersect [lsort -unique $a] $b ]] |
||||||
|
return [struct::list equal [lsort $a] $a_in_b] |
||||||
|
} |
||||||
|
>li_lib .. PatternMethod is_list_all_ni_list {a b} { |
||||||
|
package require struct::set |
||||||
|
set i [struct::set intersect $a $b] |
||||||
|
return [expr {[llength $i] == 0}] |
||||||
|
} |
||||||
|
|
||||||
|
>li_lib . new >li |
||||||
|
>li_lib . aliasprefix "li." |
||||||
|
|
||||||
|
>pattern .. Create >f_lib |
||||||
|
|
||||||
|
>f_lib .. Construct {args} { |
||||||
|
var o_this |
||||||
|
set o_this @this@ |
||||||
|
var o_last_child |
||||||
|
set o_last_child "" |
||||||
|
} |
||||||
|
>f_lib .. Method version {} { |
||||||
|
return 1.0.0 |
||||||
|
} |
||||||
|
>f_lib .. Method aliasprefix {pfx} { |
||||||
|
var o_this |
||||||
|
var o_last_child |
||||||
|
if {![string length $o_last_child]} { |
||||||
|
error ">f_lib . aliasprefix - Create library object with >f_lib . new >somename first." |
||||||
|
} |
||||||
|
set patternmethods [$o_this .. PM] |
||||||
|
set aliases [list] |
||||||
|
foreach m $patternmethods { |
||||||
|
set a ${pfx}${m} |
||||||
|
if {[llength [info commands $a]]} { |
||||||
|
puts stderr "WARNING - a command was already present at: $a" |
||||||
|
} |
||||||
|
interp alias "" $a "" [$o_last_child . $m .] |
||||||
|
lappend aliases $a |
||||||
|
} |
||||||
|
return $aliases |
||||||
|
} |
||||||
|
>f_lib .. Method new {objcmdname} { |
||||||
|
var o_this |
||||||
|
var o_last_child |
||||||
|
set nscaller [uplevel 1 [list namespace current]] |
||||||
|
if {![string match ::* $objcmdname]} { |
||||||
|
if {$nscaller eq "::"} {set nscaller ""} |
||||||
|
set objcmdname ${nscaller}::$objcmdname |
||||||
|
} |
||||||
|
uplevel 1 [list $o_this .. Create $objcmdname] |
||||||
|
set o_last_child $objcmdname |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
>f_lib .. Constructor {args} { |
||||||
|
var o_this |
||||||
|
set o_this @this@ |
||||||
|
} |
||||||
|
|
||||||
|
>f_lib .. PatternMethod foldl {total func sequence} { |
||||||
|
struct::list::Lfold $sequence $total $func |
||||||
|
} |
||||||
|
#note: foldr is not equivalent to just doing a foldl on the reversed list |
||||||
|
#todo - review/test/fix |
||||||
|
>f_lib .. PatternMethod foldr {total func sequence} { |
||||||
|
set this @this@ |
||||||
|
if {![llength $sequence]} { |
||||||
|
return $total |
||||||
|
} |
||||||
|
v,h@head,t@tail.=val $sequence |h@head,t@tail> { |
||||||
|
puts "-->$h" |
||||||
|
$func [$this . foldr $total $func $t] $h |
||||||
|
} <this@,func@,total@| $this $func $total |
||||||
|
|
||||||
|
return 0 |
||||||
|
return $v |
||||||
|
} |
||||||
|
# reduce: simplest case - list of numbers - reduce with + |
||||||
|
# more complex case: list of pipelines (e.g parsers) - reduce with 'andThen' operator of some sort. |
||||||
|
>f_lib .. PatternMethod reduce {func sequence} { |
||||||
|
struct::list::Lfold [lrange $sequence 1 end] [lindex $sequence 0] $func |
||||||
|
} |
||||||
|
>f_lib .. PatternMethod list_map {commandlist list} { |
||||||
|
tailcall lmap item $list $commandlist |
||||||
|
} |
||||||
|
>f_lib .. PatternMethod list_unique {args} { |
||||||
|
set list [concat {*}$args] |
||||||
|
set d [dict create] |
||||||
|
foreach item $list { |
||||||
|
dict set d $item "" |
||||||
|
} |
||||||
|
dict keys $d |
||||||
|
} |
||||||
|
>f_lib .. PatternMethod list_as_lines {args} { |
||||||
|
set list [concat {*}$args] |
||||||
|
join $list \n |
||||||
|
} |
||||||
|
>f_lib .. PatternMethod list_filter_cond {itemcond listval} { |
||||||
|
#maintenance - proc list_filter_cond |
||||||
|
set filtered_list [list] |
||||||
|
set binding {} |
||||||
|
if {[info level] == 1} { |
||||||
|
#up 1 is global |
||||||
|
set get_vars [list info vars] |
||||||
|
} else { |
||||||
|
set get_vars [list info locals] |
||||||
|
} |
||||||
|
set vars [uplevel 1 {*}$get_vars] |
||||||
|
set posn [lsearch $vars item] |
||||||
|
set vars [lreplace $vars $posn $posn] |
||||||
|
foreach v $vars { |
||||||
|
upvar 1 $v var |
||||||
|
if {(![array exists var]) && [info exists var]} { |
||||||
|
lappend binding [list $v $var] ;#values captured as defaults for apply args. |
||||||
|
} |
||||||
|
} |
||||||
|
#lappend binding [list item $args] |
||||||
|
|
||||||
|
#puts stderr "binding: [join $binding \n]" |
||||||
|
#apply [list $binding $pipescript [uplevel 1 namespace current]] |
||||||
|
foreach item $listval { |
||||||
|
set bindlist [list {*}$binding [list item $item]] |
||||||
|
if {[apply [list $bindlist $itemcond [uplevel 1 namespace current]] ]} { |
||||||
|
lappend filtered_list $item |
||||||
|
} |
||||||
|
} |
||||||
|
return $filtered_list |
||||||
|
} |
||||||
|
|
||||||
|
>f_lib .. PatternMethod sum_llength {total listval} { |
||||||
|
expr {$total + [llength $listval]} |
||||||
|
} |
||||||
|
>f_lib .. PatternMethod sum_length {total stringval} { |
||||||
|
expr {$total + [string length $stringval]} |
||||||
|
} |
||||||
|
>f_lib .. PatternMethod debug {total item} { |
||||||
|
puts stderr "incr tally: $total item: $item" |
||||||
|
expr {$total + 1} |
||||||
|
} |
||||||
|
>f_lib .. PatternMethod dict_walk {d key} { |
||||||
|
dict get $d $key |
||||||
|
} |
||||||
|
>f_lib .. PatternMethod sum {total num} { |
||||||
|
expr {$total + $num} |
||||||
|
} |
||||||
|
>f_lib .. PatternMethod lcomp {expression args} { |
||||||
|
#from https://wiki.tcl-lang.org/page/lcomp |
||||||
|
set __0__ "lappend __1__ \[expr [list $expression]\]" |
||||||
|
while {[llength $args] && [lindex $args 0] ni {for if with}} { |
||||||
|
append __0__ " \[expr [list [lindex $args 0]]\]" |
||||||
|
set args [lrange $args 1 end] |
||||||
|
} |
||||||
|
set tmpvar 2 |
||||||
|
set structure {} |
||||||
|
set upvars {} |
||||||
|
while {[llength $args]} { |
||||||
|
set prefix "" |
||||||
|
switch [lindex $args 0] { |
||||||
|
for { |
||||||
|
set nest [list foreach] |
||||||
|
while {[llength $nest] == 1 || [lindex $args 0] eq "and"} { |
||||||
|
if {[llength $args] < 4 || [lindex $args 2] ni {in inside}} { |
||||||
|
error "wrong # operands: must be \"for\" vars \"in?side?\"\ |
||||||
|
vals ?\"and\" vars \"in?side?\" vals? ?...?" |
||||||
|
} |
||||||
|
switch [lindex $args 2] { |
||||||
|
in { |
||||||
|
lappend nest [lindex $args 1] [lindex $args 3] |
||||||
|
} inside { |
||||||
|
lappend nest __${tmpvar}__ [lindex $args 3] |
||||||
|
append prefix "lassign \$__${tmpvar}__ [lindex $args 1]\n" |
||||||
|
incr tmpvar |
||||||
|
}} |
||||||
|
set args [lrange $args 4 end] |
||||||
|
} |
||||||
|
lappend structure $nest $prefix |
||||||
|
} if { |
||||||
|
if {[llength $args] < 2} { |
||||||
|
error "wrong # operands: must be \"if\" condition" |
||||||
|
} |
||||||
|
lappend structure [list if [lindex $args 1]] $prefix |
||||||
|
set args [lrange $args 2 end] |
||||||
|
} with { |
||||||
|
if {[llength $args] < 2} { |
||||||
|
error "wrong # operands: must be \"with\" varlist" |
||||||
|
} |
||||||
|
foreach var [lindex $args 1] { |
||||||
|
lappend upvars $var $var |
||||||
|
} |
||||||
|
set args [lrange $args 2 end] |
||||||
|
} default { |
||||||
|
error "bad opcode \"[lindex $args 0]\": must be for, if, or with" |
||||||
|
}} |
||||||
|
} |
||||||
|
foreach {prefix nest} [lreverse $structure] { |
||||||
|
set __0__ [concat $nest [list \n$prefix$__0__]] |
||||||
|
} |
||||||
|
if {[llength $upvars]} { |
||||||
|
set __0__ "upvar 1 $upvars; $__0__" |
||||||
|
} |
||||||
|
unset -nocomplain expression args tmpvar prefix nest structure var upvars |
||||||
|
set __1__ "" |
||||||
|
eval $__0__ |
||||||
|
return $__1__ |
||||||
|
} |
||||||
|
|
||||||
|
>f_lib . new ::punk::lib::>f |
||||||
|
>f_lib . aliasprefix "f." |
||||||
|
interp alias {} >f {} ::punk::lib::>f |
||||||
|
|
||||||
|
|
||||||
|
#Pattern-matching based functional operations |
||||||
|
>pattern .. Create >P |
||||||
|
>P .. Method map {pattern commandlist sequence} { |
||||||
|
#set segment [string map [list <cmd> $commandlist] {<cmd>}] |
||||||
|
|
||||||
|
set pipeline [list % {val $item} "|,item,$pattern>" $commandlist <item/0|] |
||||||
|
tailcall % list $pipeline $sequence |p/0,l/1> {lmap val $l {{*}$p $val }} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
@ -0,0 +1,216 @@ |
|||||||
|
package provide punk::mix::base [namespace eval punk::mix::base { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
|
#base internal plumbing functions |
||||||
|
namespace eval punk::mix::base { |
||||||
|
proc set_alias {cmdname args} { |
||||||
|
extension@@opts/@?@-extension,args@@args= [_split_args $args] |
||||||
|
uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] |
||||||
|
} |
||||||
|
proc _cli {args} { |
||||||
|
extension@@opts/@?@-extension,args@@args= [_split_args $args] |
||||||
|
if {![string length $extension]} { |
||||||
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||||
|
} |
||||||
|
puts stderr ">>> extension:$extension" |
||||||
|
if {![llength $args]} { |
||||||
|
if {[info exists ${extension}::default_command]} { |
||||||
|
tailcall $extension [set ${extension}::default_command] |
||||||
|
} |
||||||
|
tailcall $extension |
||||||
|
} else { |
||||||
|
tailcall $extension {*}$args |
||||||
|
} |
||||||
|
} |
||||||
|
proc _unknown {ns args} { |
||||||
|
extension@@opts/@?@-extension,args@@args= [_split_args $args] |
||||||
|
if {![string length $extension]} { |
||||||
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||||
|
} |
||||||
|
puts stderr "arglen:[llength $args]" |
||||||
|
puts stdout "_unknown '$ns' '$args'" |
||||||
|
|
||||||
|
set d_commands [get_commands -extension $extension] |
||||||
|
set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] |
||||||
|
error "Unknown subcommand \"[lindex $args 0]\": must be one of: $all_commands" "punk::mix::base _unknown $ns $args" [list unknown_ensemble_subcommand ensemble punk::mix::base] |
||||||
|
} |
||||||
|
proc _redirected {from_ns subcommand args} { |
||||||
|
puts stderr "_redirected from_ns: $from_ns subcommand:$subcommand args:$args" |
||||||
|
set pname [namespace current]::$subcommand |
||||||
|
if {$pname in [info procs $pname]} { |
||||||
|
set argnames [info args $pname] |
||||||
|
puts stderr "$subcommand argnames: $argnames" |
||||||
|
if {[lindex $argnames end] eq "args"} { |
||||||
|
set pos_argnames [lrange $argnames 0 end-1] |
||||||
|
} else { |
||||||
|
set pos_argnames $argnames |
||||||
|
} |
||||||
|
set argvals [list] |
||||||
|
set numargs [llength $pos_argnames] |
||||||
|
if {$numargs > 0} { |
||||||
|
set argvals [lrange $args 0 $numargs-1] |
||||||
|
set args [lrange $args $numargs end] |
||||||
|
} |
||||||
|
if {[llength $argvals] < $numargs} { |
||||||
|
error "wrong # args: $from_ns $subcommand requires args: $pos_argnames" |
||||||
|
} |
||||||
|
tailcall [namespace current] $subcommand {*}$argvals {*}$args -extension $from_ns |
||||||
|
} else { |
||||||
|
tailcall [namespace current] $subcommand {*}$args -extension $from_ns |
||||||
|
} |
||||||
|
} |
||||||
|
proc _split_args {arglist} { |
||||||
|
#don't assume arglist is fully paired. |
||||||
|
set posn [lsearch $arglist -extension] |
||||||
|
set opts [list] |
||||||
|
if {$posn >= 0} { |
||||||
|
if {$posn+2 <= [llength $arglist]} { |
||||||
|
set opts [list -extension [lindex $arglist $posn+1]] |
||||||
|
set argsremaining [lreplace $arglist $posn $posn+1] |
||||||
|
} else { |
||||||
|
#no value supplied to -extension |
||||||
|
error "punk::mix::base::_split_args - no value found for option '-extension'. Supply a value or omit the option." |
||||||
|
} |
||||||
|
} else { |
||||||
|
set argsremaining $arglist |
||||||
|
} |
||||||
|
|
||||||
|
return [list opts $opts args $argsremaining] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#base API (potentially overridden functions - may also be called from overriding namespace) |
||||||
|
#commands should either handle or silently ignore -extension <namespace/ensemble> |
||||||
|
namespace eval punk::mix::base { |
||||||
|
namespace ensemble create |
||||||
|
namespace export help dostuff get_commands set_alias |
||||||
|
namespace ensemble configure [namespace current] -unknown punk::mix::base::_unknown |
||||||
|
proc get_commands {args} { |
||||||
|
extension@@opts/@?@-extension,args@@args= [_split_args $args] |
||||||
|
if {![string length $extension]} { |
||||||
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||||
|
} |
||||||
|
|
||||||
|
set maincommands [list] |
||||||
|
#extension may still be blank e.g if punk::mix::base::get_commands called directly |
||||||
|
if {[string length $extension]} { |
||||||
|
set nsmain $extension |
||||||
|
puts stdout "get_commands nsmain: $nsmain" |
||||||
|
set parentpatterns [namespace eval $nsmain [list namespace export]] |
||||||
|
set nscommands [list] |
||||||
|
foreach p $parentpatterns { |
||||||
|
lappend nscommands {*}[info commands ${nsmain}::$p] |
||||||
|
} |
||||||
|
foreach c $nscommands { |
||||||
|
set cmd [namespace tail $c] |
||||||
|
lappend maincommands $cmd |
||||||
|
} |
||||||
|
set maincommands [lsort $maincommands] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
set nsbase [namespace current] |
||||||
|
set basepatterns [namespace export] |
||||||
|
puts stdout "basepatterns:$basepatterns" |
||||||
|
set nscommands [list] |
||||||
|
foreach p $basepatterns { |
||||||
|
lappend nscommands {*}[info commands ${nsbase}::$p] |
||||||
|
} |
||||||
|
|
||||||
|
set basecommands [list] |
||||||
|
foreach c $nscommands { |
||||||
|
set cmd [namespace tail $c] |
||||||
|
if {$cmd ni $maincommands} { |
||||||
|
lappend basecommands $cmd |
||||||
|
} |
||||||
|
} |
||||||
|
set basecommands [lsort $basecommands] |
||||||
|
|
||||||
|
|
||||||
|
return [list main $maincommands base $basecommands] |
||||||
|
} |
||||||
|
proc help {args} { |
||||||
|
#' **%ensemblecommand% help** *args* |
||||||
|
#' |
||||||
|
#' Help for ensemble commands in the command line interface |
||||||
|
#' |
||||||
|
#' |
||||||
|
#' Arguments: |
||||||
|
#' |
||||||
|
#' * args - first word of args is the helptopic requested - usually a command name |
||||||
|
#' - calling help with no arguments will list available commands |
||||||
|
#' |
||||||
|
#' Returns: help text (text) |
||||||
|
#' |
||||||
|
#' Examples: |
||||||
|
#' |
||||||
|
#' ``` |
||||||
|
#' %ensemblecommand% help <commandname> |
||||||
|
#' ``` |
||||||
|
#' |
||||||
|
#' |
||||||
|
|
||||||
|
|
||||||
|
#extension.= @@opts/@?@-extension,args@@args=>. [_split_args $args] {| |
||||||
|
# >} inspect -label a {| |
||||||
|
# >} .=e>end,data>end pipeswitch { |
||||||
|
# pipecase ,0/1/#= $switchargs {| |
||||||
|
# e/0 |
||||||
|
# >} .=>. {set e} |
||||||
|
# pipecase /1,1/1/#= $switchargs |
||||||
|
#} |@@ok/result> <e/0| [namespace qualifiers [lindex [info level -1] 0]] |
||||||
|
|
||||||
|
|
||||||
|
extension@@opts/@?@-extension,args@@args= [_split_args $args] |
||||||
|
if {![string length $extension]} { |
||||||
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||||
|
} |
||||||
|
#puts stderr "-1:[info level -1]" |
||||||
|
|
||||||
|
set command_info [punk::mix::base::get_commands -extension $extension] |
||||||
|
set subhelp1 [lindex $args 0] |
||||||
|
if {[string length $subhelp1]} { |
||||||
|
if {$subhelp1 in [dict get $command_info main]} { |
||||||
|
set procname ${extension}::$subhelp1 |
||||||
|
if {$procname in [info procs $procname]} { |
||||||
|
set argnames [info args $procname] |
||||||
|
} else { |
||||||
|
set argnames "(No info available)" |
||||||
|
} |
||||||
|
return "$subhelp1 $argnames" |
||||||
|
} elseif {$subhelp1 in [dict get $command_info base]} { |
||||||
|
set procname [namespace current]::$subhelp1 |
||||||
|
if {$procname in [info procs $procname]} { |
||||||
|
set argnames [info args $procname] |
||||||
|
} else { |
||||||
|
set argnames "(No info available)" |
||||||
|
} |
||||||
|
return "$subhelp1 $argnames" |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
set helpstr "" |
||||||
|
append helpstr "commands:\n" |
||||||
|
|
||||||
|
foreach {source cmdlist} $command_info { |
||||||
|
append helpstr \n " $source" |
||||||
|
foreach cmd $cmdlist { |
||||||
|
append helpstr \n " - $cmd" |
||||||
|
} |
||||||
|
} |
||||||
|
return $helpstr |
||||||
|
} |
||||||
|
proc dostuff {args} { |
||||||
|
extension@@opts/@?@-extension,args@@args= [_split_args $args] |
||||||
|
|
||||||
|
puts stdout "base doingstuff-with-args:'$args'-in-namespace:'[namespace current]'" |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
@ -0,0 +1,13 @@ |
|||||||
|
Home /home * {} |
||||||
|
Timeline /timeline {o r j} {} |
||||||
|
Files /dir?ci=tip oh desktoponly |
||||||
|
Branches /brlist o wideonly |
||||||
|
Tags /taglist o wideonly |
||||||
|
Forum /forum {@2 3 4 5 6} wideonly |
||||||
|
Chat /chat C wideonly |
||||||
|
Tickets /ticket r wideonly |
||||||
|
Wiki /wiki j wideonly |
||||||
|
Download /download * {} |
||||||
|
Admin /setup {a s} desktoponly |
||||||
|
Logout /logout L wideonly |
||||||
|
Login /login !L wideonly |
||||||
@ -0,0 +1,3 @@ |
|||||||
|
src |
||||||
|
src/deps |
||||||
|
src/modules |
||||||
@ -1,14 +1,29 @@ |
|||||||
#The directory for compiled/built Tcl modules |
.git |
||||||
/modules/ |
bin |
||||||
|
lib |
||||||
#Temporary files e.g from tests |
#The directory for compiled/built Tcl modules |
||||||
/tmp/ |
modules |
||||||
|
|
||||||
/logs/ |
#Temporary files e.g from tests |
||||||
|
tmp |
||||||
#Built tclkits (if any) |
|
||||||
punk*.exe |
logs |
||||||
tcl*.exe |
_aside |
||||||
|
_build |
||||||
#miscellaneous editor files etc |
|
||||||
*.swp |
#Built documentation |
||||||
|
html |
||||||
|
man |
||||||
|
md |
||||||
|
doc |
||||||
|
|
||||||
|
test* |
||||||
|
|
||||||
|
#Built tclkits (if any) |
||||||
|
punk*.exe |
||||||
|
tcl*.exe |
||||||
|
|
||||||
|
#miscellaneous editor files etc |
||||||
|
*.swp |
||||||
|
|
||||||
|
todo.txt |
||||||
@ -0,0 +1,38 @@ |
|||||||
|
|
||||||
|
/bin/ |
||||||
|
/lib/ |
||||||
|
#The directory for compiled/built Tcl modules |
||||||
|
/modules/ |
||||||
|
|
||||||
|
#Temporary files e.g from tests |
||||||
|
/tmp/ |
||||||
|
|
||||||
|
/logs/ |
||||||
|
/_aside/ |
||||||
|
/_build/ |
||||||
|
|
||||||
|
#Built documentation |
||||||
|
/html/ |
||||||
|
/man/ |
||||||
|
/md/ |
||||||
|
/doc/ |
||||||
|
|
||||||
|
/test* |
||||||
|
|
||||||
|
|
||||||
|
#Built tclkits (if any) |
||||||
|
punk*.exe |
||||||
|
tcl*.exe |
||||||
|
|
||||||
|
#ignore fossil database files (but keep .fossil-settings even if fossil not being used at your site) |
||||||
|
_FOSSIL_ |
||||||
|
*.fossil |
||||||
|
|
||||||
|
#miscellaneous editor files etc |
||||||
|
*.swp |
||||||
|
|
||||||
|
|
||||||
|
todo.txt |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -0,0 +1,14 @@ |
|||||||
|
%project% |
||||||
|
============================== |
||||||
|
|
||||||
|
+ |
||||||
|
+ |
||||||
|
|
||||||
|
|
||||||
|
About |
||||||
|
------------------------------ |
||||||
|
|
||||||
|
+ |
||||||
|
+ |
||||||
|
+ |
||||||
|
|
||||||
@ -0,0 +1,195 @@ |
|||||||
|
# tcl |
||||||
|
# |
||||||
|
#make any tclkits and modules in src and place them and associated data files/scripts in the parent folder of src. |
||||||
|
#e.g in 'bin' and 'modules' folders at same level as 'src' folder. |
||||||
|
#It is assumed the src folder has been placed somewhere where appropriate |
||||||
|
#(e.g not in /usr or c:/ - unless you intend it to directly make and place folders and files in those locations) |
||||||
|
|
||||||
|
package require punk::mix |
||||||
|
|
||||||
|
if {[lsearch $::argv -k] >= 0} { |
||||||
|
set forcekill 1 |
||||||
|
} else { |
||||||
|
set forcekill 0 |
||||||
|
} |
||||||
|
puts stdout "::argv $::argv" |
||||||
|
set sourcefolder [file normalize [file dirname [info script]]] |
||||||
|
# ---------------------------------------- |
||||||
|
|
||||||
|
set target_modules_base [file dirname $sourcefolder]/modules |
||||||
|
file mkdir $target_modules_base |
||||||
|
|
||||||
|
#external modules first - and any supporting files - no 'building' required |
||||||
|
set copied [punk::mix::cli::lib::copy_files_from_source_to_base $sourcefolder/deps $target_modules_base -force 1] |
||||||
|
puts stderr "Copied [llength $copied] dependencies" |
||||||
|
|
||||||
|
|
||||||
|
set src_module_dir $sourcefolder/modules |
||||||
|
#modules and associated files belonging to this package/app |
||||||
|
set copied [punk::mix::cli::lib::build_modules_from_source_to_base $src_module_dir $target_modules_base -glob *.tm] ;#will only accept a glob ending in .tm |
||||||
|
puts stderr "Copied [llength $copied] app modules" |
||||||
|
|
||||||
|
set copied [punk::mix::cli::lib::copy_nonmodules_from_source_to_base $src_module_dir $target_modules_base -force 1] |
||||||
|
|
||||||
|
|
||||||
|
# ---------------------------------------- |
||||||
|
|
||||||
|
set vfs_folders [glob -nocomplain -dir $sourcefolder -types d -tail *.vfs] |
||||||
|
if {![llength $vfs_folders]} { |
||||||
|
puts stdout "No .vfs folders found at '$sourcefolder' - no kits to build" |
||||||
|
puts stdout " -done- " |
||||||
|
exit 0 |
||||||
|
} |
||||||
|
file mkdir $sourcefolder/_build |
||||||
|
|
||||||
|
if {[catch {exec sdx help} errM]} { |
||||||
|
puts stderr "FAILED to find usable sdx command - check that sdx executable is on path" |
||||||
|
puts stderr "err: $errM" |
||||||
|
exit 1 |
||||||
|
} |
||||||
|
#find runtime - only supports one for now.. REVIEW |
||||||
|
set rtfolder $sourcefolder/runtime |
||||||
|
set runtimes [glob -nocomplain -dir $rtfolder -types {f x} -tail *] |
||||||
|
if {![llength $runtimes]} { |
||||||
|
puts stderr "No executable runtimes found in $rtfolder - unable to build any .vfs folders into executables." |
||||||
|
exit 2 |
||||||
|
} |
||||||
|
if {[llength $runtimes] > 1} { |
||||||
|
puts stderr "Found multiple runtimes in $rtfolder ($runtimes) - unable to proceed - currently limited to one." |
||||||
|
exit 3 |
||||||
|
} |
||||||
|
|
||||||
|
set runtimefile [lindex $runtimes 0] |
||||||
|
|
||||||
|
puts stdout "Found [llength $vfs_folders] .vfs folders - building executable for each..." |
||||||
|
foreach vfs $vfs_folders { |
||||||
|
set vfsname [file rootname $vfs] |
||||||
|
puts stdout " Processing vfs $sourcefolder/$vfs" |
||||||
|
puts stdout " ------------------------------------" |
||||||
|
|
||||||
|
if {[file exists $sourcefolder/_build/$vfsname]} { |
||||||
|
puts stderr "deleting existing $sourcefolder/_build/$vfsname" |
||||||
|
file delete $sourcefolder/_build/$vfsname |
||||||
|
} |
||||||
|
|
||||||
|
puts stdout "building $vfsname with sdx.." |
||||||
|
|
||||||
|
if {[catch { |
||||||
|
exec sdx wrap _build/$vfsname -runtime runtime/$runtimefile -verbose |
||||||
|
} result]} { |
||||||
|
puts stderr "sdx wrap _build/$vfsname -runtime runtime/$runtimefile -verbose failed with msg: $result" |
||||||
|
} else { |
||||||
|
puts stdout "ok - finished sdx" |
||||||
|
set separator [string repeat = 40] |
||||||
|
puts stdout $separator |
||||||
|
puts stdout $result |
||||||
|
puts stdout $separator |
||||||
|
} |
||||||
|
|
||||||
|
if {![file exists $sourcefolder/_build/$vfsname]} { |
||||||
|
puts stderr "|err> build didn't seem to produce output at $sourcefolder/_build/$vfsname" |
||||||
|
exit 2 |
||||||
|
} |
||||||
|
|
||||||
|
if {$::tcl_platform(platform) eq "windows"} { |
||||||
|
set pscmd "tasklist" |
||||||
|
} else { |
||||||
|
set pscmd "ps" |
||||||
|
} |
||||||
|
|
||||||
|
if {![catch { |
||||||
|
exec $pscmd | grep $vfsname |
||||||
|
} still_running]} { |
||||||
|
puts stdout "found $vfsname instances still running\n" |
||||||
|
set count_killed 0 |
||||||
|
foreach ln [split $still_running \n] { |
||||||
|
puts stdout " $ln" |
||||||
|
|
||||||
|
if {$::tcl_platform(platform) eq "windows"} { |
||||||
|
set pid [lindex $ln 1] |
||||||
|
if {$forcekill} { |
||||||
|
set killcmd [list taskkill /F /PID $pid] |
||||||
|
} else { |
||||||
|
set killcmd [list taskkill /PID $pid] |
||||||
|
} |
||||||
|
} else { |
||||||
|
set pid [lindex $ln 0] |
||||||
|
#review! |
||||||
|
if {$forcekill} { |
||||||
|
set killcmd [list kill -9 $pid] |
||||||
|
} else { |
||||||
|
set killcmd [list kill $pid] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
puts stdout " pid: $pid (attempting to kill now using '$killcmd')" |
||||||
|
|
||||||
|
if {[catch { |
||||||
|
exec {*}$killcmd |
||||||
|
} errMsg]} { |
||||||
|
puts stderr "$killcmd returned an error:" |
||||||
|
puts stderr $errMsg |
||||||
|
puts stderr "(try '[info script] -k' option to force kill)" |
||||||
|
exit 4 |
||||||
|
} else { |
||||||
|
puts stderr "$killcmd ran without error" |
||||||
|
incr count_killed |
||||||
|
} |
||||||
|
} |
||||||
|
if {$count_killed > 0} { |
||||||
|
puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable" |
||||||
|
after 1000 |
||||||
|
} |
||||||
|
} else { |
||||||
|
puts stderr "Ok.. no running '$vfsname' processes found" |
||||||
|
} |
||||||
|
|
||||||
|
if {$::tcl_platform(platform) eq "windows"} { |
||||||
|
set targetexe ${vfsname}.exe |
||||||
|
} else { |
||||||
|
set targetexe $vfsname |
||||||
|
} |
||||||
|
|
||||||
|
if {[file exists $sourcefolder/_build/$targetexe]} { |
||||||
|
puts stderr "deleting existing $sourcefolder/_build/$targetexe" |
||||||
|
if {[catch { |
||||||
|
file delete $sourcefolder/_build/$targetexe |
||||||
|
} msg]} { |
||||||
|
puts stderr "Failed to delete $sourcefolder/_build/$targetexe" |
||||||
|
exit 4 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$::tcl_platform(platform) eq "windows"} { |
||||||
|
file rename $sourcefolder/_build/$vfsname $sourcefolder/_build/${vfsname}.exe |
||||||
|
} |
||||||
|
|
||||||
|
after 200 |
||||||
|
set deployment_folder [file dirname $sourcefolder]/bin |
||||||
|
file mkdir $deployment_folder |
||||||
|
|
||||||
|
if {[file exists $deployment_folder/$targetexe]} { |
||||||
|
puts stderr "deleting existing deployed at $deployment_folder/$targetexe" |
||||||
|
if {[catch { |
||||||
|
file delete $deployment_folder/$targetexe |
||||||
|
} errMsg]} { |
||||||
|
puts stderr "deletion of deployed version at $deployment_folder/$targetexe failed: $errMsg" |
||||||
|
exit 5 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
puts stdout "copying.." |
||||||
|
puts stdout "$sourcefolder/_build/$targetexe" |
||||||
|
puts stdout "to:" |
||||||
|
puts stdout "$deployment_folder/$targetexe" |
||||||
|
after 500 |
||||||
|
file copy $sourcefolder/_build/$targetexe $deployment_folder/$targetexe |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
puts stdout "done" |
||||||
|
exit 0 |
||||||
|
|
||||||
|
|
||||||
@ -0,0 +1,3 @@ |
|||||||
|
%Major.Minor.Level% |
||||||
|
#First line must be a semantic version number |
||||||
|
#all other lines are ignored. |
||||||
@ -0,0 +1,51 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) %year% |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application %pkg% 999999.0a1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license %license% |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval %pkg% { |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide %pkg% [namespace eval %pkg% { |
||||||
|
variable version |
||||||
|
set version 999999.0a1.0 |
||||||
|
}] |
||||||
|
return |
||||||
@ -1,12 +0,0 @@ |
|||||||
package provide punk::mix_custom [namespace eval punk::mix_custom { |
|
||||||
variable version |
|
||||||
set version 0.1 |
|
||||||
}] |
|
||||||
|
|
||||||
|
|
||||||
namespace eval punk::mix_custom { |
|
||||||
proc dostuff {args} { |
|
||||||
puts stdout doingstuff-$args |
|
||||||
} |
|
||||||
|
|
||||||
} |
|
||||||
@ -0,0 +1,62 @@ |
|||||||
|
|
||||||
|
package provide [lindex [list [set ver [join [lassign [split [ file tail [file rootname [info script] ]] -] pkg] -]] $pkg] 1]\ |
||||||
|
[namespace eval $pkg[unset pkg] {list [variable version $ver[unset ver]]$version}] |
||||||
|
|
||||||
|
#package provide [lassign {overtype 1.4} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $ver[set ver {}]]$version}] |
||||||
|
|
||||||
|
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 |
||||||
|
proc custom_from_base {routine base} { |
||||||
|
if {![string match ::* $routine]} { |
||||||
|
set resolved [uplevel 1 [list ::namespace which $routine]] |
||||||
|
if {$resolved eq {}} { |
||||||
|
error [list {no such routine} $routine] |
||||||
|
} |
||||||
|
set routine $resolved |
||||||
|
} |
||||||
|
set routinens [namespace qualifiers $routine] |
||||||
|
if {$routinens eq {::}} { |
||||||
|
set routinens {} |
||||||
|
} |
||||||
|
set routinetail [namespace tail $routine] |
||||||
|
|
||||||
|
if {![string match ::* $base]} { |
||||||
|
set base [uplevel 1 [ |
||||||
|
list [namespace which namespace] current]]::$base |
||||||
|
} |
||||||
|
|
||||||
|
if {![namespace exists $base]} { |
||||||
|
error [list {no such namespace} $base] |
||||||
|
} |
||||||
|
|
||||||
|
set base [namespace eval $base [ |
||||||
|
list [namespace which namespace] current]] |
||||||
|
|
||||||
|
|
||||||
|
#while 1 { |
||||||
|
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||||
|
# if {[namespace which $renamed] eq {}} break |
||||||
|
#} |
||||||
|
|
||||||
|
namespace eval $routine [ |
||||||
|
list namespace ensemble configure $routine -unknown [ |
||||||
|
list apply {{base ensemble subcommand args} { |
||||||
|
list ${base}::_redirected $ensemble $subcommand |
||||||
|
}} $base |
||||||
|
] |
||||||
|
] |
||||||
|
namespace eval $routine { |
||||||
|
set exportlist [list] |
||||||
|
foreach cmd [info commands [namespace current]::*] { |
||||||
|
set c [namespace tail $cmd] |
||||||
|
if {![string match _* $c]} { |
||||||
|
lappend exportlist $c |
||||||
|
} |
||||||
|
} |
||||||
|
namespace export {*}$exportlist |
||||||
|
} |
||||||
|
|
||||||
|
return $routine |
||||||
|
} |
||||||
|
} |
||||||
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Loading…
Reference in new issue