From 9013ca58071fa92032737e54456d4375712966cf Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Sun, 17 Dec 2023 06:49:13 +1100 Subject: [PATCH] bootsupport recursion fix --- src/bootsupport/include_modules.config | 5 + src/bootsupport/modules/oolib-0.1.tm | 390 ++-- src/bootsupport/modules/punk/cap-0.1.0.tm | 386 +++- .../punk/cap/handlers/caphandler-0.1.0.tm | 52 + .../punk/cap/handlers/scriptlibs-0.1.0.tm | 52 + .../punk/cap/handlers/templates-0.1.0.tm | 127 ++ src/bootsupport/modules/punk/mix-0.2.tm | 8 +- src/bootsupport/modules/punk/mix/base-0.1.tm | 1812 +++++++++-------- .../punk/mix/commandset/layout-0.1.0.tm | 2 +- .../punk/mix/commandset/project-0.1.0.tm | 10 +- .../modules/punk/mix/templates-0.1.0.tm | 37 +- src/bootsupport/modules/punk/overlay-0.1.tm | 316 +-- src/make.tcl | 152 +- .../src/bootsupport/modules/oolib-0.1.tm | 390 ++-- .../src/bootsupport/modules/punk/cap-0.1.0.tm | 386 +++- .../punk/cap/handlers/caphandler-0.1.0.tm | 52 + .../punk/cap/handlers/scriptlibs-0.1.0.tm | 52 + .../punk/cap/handlers/templates-0.1.0.tm | 127 ++ .../src/bootsupport/modules/punk/mix-0.2.tm | 8 +- .../bootsupport/modules/punk/mix/base-0.1.tm | 1812 +++++++++-------- .../punk/mix/commandset/layout-0.1.0.tm | 2 +- .../punk/mix/commandset/project-0.1.0.tm | 10 +- .../modules/punk/mix/templates-0.1.0.tm | 37 +- .../bootsupport/modules/punk/overlay-0.1.tm | 316 +-- src/mixtemplates/layouts/basic/src/make.tcl | 152 +- .../cap/handlers/templates-999999.0a1.0.tm | 6 +- .../src/bootsupport/modules/oolib-0.1.tm | 390 ++-- .../src/bootsupport/modules/punk/cap-0.1.0.tm | 386 +++- .../punk/cap/handlers/caphandler-0.1.0.tm | 52 + .../punk/cap/handlers/scriptlibs-0.1.0.tm | 52 + .../punk/cap/handlers/templates-0.1.0.tm | 127 ++ .../src/bootsupport/modules/punk/mix-0.2.tm | 8 +- .../bootsupport/modules/punk/mix/base-0.1.tm | 1812 +++++++++-------- .../punk/mix/commandset/layout-0.1.0.tm | 2 +- .../punk/mix/commandset/project-0.1.0.tm | 10 +- .../modules/punk/mix/templates-0.1.0.tm | 37 +- .../bootsupport/modules/punk/overlay-0.1.tm | 316 +-- .../templates/layouts/project/src/make.tcl | 152 +- 38 files changed, 5774 insertions(+), 4269 deletions(-) create mode 100644 src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm create mode 100644 src/bootsupport/modules/punk/cap/handlers/scriptlibs-0.1.0.tm create mode 100644 src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/scriptlibs-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap/handlers/scriptlibs-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm diff --git a/src/bootsupport/include_modules.config b/src/bootsupport/include_modules.config index 1ba6c227..94164072 100644 --- a/src/bootsupport/include_modules.config +++ b/src/bootsupport/include_modules.config @@ -31,3 +31,8 @@ set bootsupport_modules [list\ modules punk::tdl\ modules punk::winpath\ ] + + +#Don't include punk/mix/templates - recursive bootsupport problem! +set bootsupport_module_folders [list\ +] diff --git a/src/bootsupport/modules/oolib-0.1.tm b/src/bootsupport/modules/oolib-0.1.tm index 9cf1ca07..3756fceb 100644 --- a/src/bootsupport/modules/oolib-0.1.tm +++ b/src/bootsupport/modules/oolib-0.1.tm @@ -1,195 +1,195 @@ -#JMN - api should be kept in sync with package patternlib where possible -# -package provide oolib [namespace eval oolib { - variable version - set version 0.1 -}] - -namespace eval oolib { - oo::class create collection { - variable o_data ;#dict - variable o_alias - constructor {} { - set o_data [dict create] - } - method info {} { - return [dict info $o_data] - } - method count {} { - return [dict size $o_data] - } - method isEmpty {} { - expr {[dict size $o_data] == 0} - } - method names {{globOrIdx {}}} { - if {[llength $globOrIdx]} { - if {[string is integer -strict $globOrIdx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $idx} result]} { - error "[self object] no such index : '$idx'" - } else { - return $result - } - } else { - #glob - return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] - } - } else { - return [dict keys $o_data] - } - } - #like names but without globbing - method keys {} { - dict keys $o_data - } - method key {{posn 0}} { - if {$posn < 0} { - set posn "end-[expr {abs($posn + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $posn} result]} { - error "[self object] no such index : '$posn'" - } else { - return $result - } - } - method hasKey {key} { - dict exists $o_data $key - } - method get {} { - return $o_data - } - method items {} { - return [dict values $o_data] - } - method item {key} { - if {[string is integer -strict $key]} { - if {$key > 0} { - set valposn [expr {(2*$key) +1}] - return [lindex $o_data $valposn] - } else { - set key "end-[expr {abs($key + 1)}]" - return [lindex [dict keys $o_data] $key] - } - } - if {[dict exists $o_data $key]} { - return [dict get $o_data $key] - } - } - #inverse lookup - method itemKeys {value} { - set value_indices [lsearch -all [dict values $o_data] $value] - set keylist [list] - foreach i $value_indices { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - method search {value args} { - set matches [lsearch {*}$args [dict values $o_data] $value] - if {"-inline" in $args} { - return $matches - } else { - set keylist [list] - foreach i $matches { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - } - #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? - method alias {newAlias existingKeyOrAlias} { - if {[string is integer -strict $newAlias]} { - error "[self object] collection key alias cannot be integer" - } - if {[string length $existingKeyOrAlias]} { - set o_alias($newAlias) $existingKeyOrAlias - } else { - unset o_alias($newAlias) - } - } - method aliases {{key ""}} { - if {[string length $key]} { - set result [list] - foreach {n v} [array get o_alias] { - if {$v eq $key} { - lappend result $n $v - } - } - return $result - } else { - return [array get o_alias] - } - } - #if the supplied index is an alias, return the underlying key; else return the index supplied. - method realKey {idx} { - if {[catch {set o_alias($idx)} key]} { - return $idx - } else { - return $key - } - } - method add {value key} { - if {[string is integer -strict $key]} { - error "[self object] collection key must not be an integer. Use another structure if integer keys required" - } - if {[dict exists $o_data $key]} { - error "[self object] col_processors object error: key '$key' already exists in collection" - } - dict set o_data $key $value - return [expr {[dict size $o_data] - 1}] ;#return index of item - } - method remove {idx {endRange ""}} { - if {[string length $endRange]} { - error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" - } - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx+1)}]" - } - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - if {$posn < 0} { - error "[self object] no such index: '$idx' in this collection" - } - } - dict unset o_data $key - return - } - method clear {} { - set o_data [dict create] - return - } - method reverse {} { - set dictnew [dict create] - foreach k [lreverse [dict keys $o_data]] { - dict set dictnew $k [dict get $o_data $k] - } - set o_data $dictnew - return - } - #review - cmd as list vs cmd as script? - method map {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list {*}$cmd $v]] - } - return $seed - } - method objectmap {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list $v {*}$cmd]] - } - return $seed - } - } - -} - +#JMN - api should be kept in sync with package patternlib where possible +# +package provide oolib [namespace eval oolib { + variable version + set version 0.1 +}] + +namespace eval oolib { + oo::class create collection { + variable o_data ;#dict + variable o_alias + constructor {} { + set o_data [dict create] + } + method info {} { + return [dict info $o_data] + } + method count {} { + return [dict size $o_data] + } + method isEmpty {} { + expr {[dict size $o_data] == 0} + } + method names {{globOrIdx {}}} { + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "[self object] no such index : '$idx'" + } else { + return $result + } + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } + } + #like names but without globbing + method keys {} { + dict keys $o_data + } + method key {{posn 0}} { + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "[self object] no such index : '$posn'" + } else { + return $result + } + } + method hasKey {key} { + dict exists $o_data $key + } + method get {} { + return $o_data + } + method items {} { + return [dict values $o_data] + } + method item {key} { + if {[string is integer -strict $key]} { + if {$key > 0} { + set valposn [expr {(2*$key) +1}] + return [lindex $o_data $valposn] + } else { + set key "end-[expr {abs($key + 1)}]" + return [lindex [dict keys $o_data] $key] + } + } + if {[dict exists $o_data $key]} { + return [dict get $o_data $key] + } + } + #inverse lookup + method itemKeys {value} { + set value_indices [lsearch -all [dict values $o_data] $value] + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + method search {value args} { + set matches [lsearch {*}$args [dict values $o_data] $value] + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + } + #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? + method alias {newAlias existingKeyOrAlias} { + if {[string is integer -strict $newAlias]} { + error "[self object] collection key alias cannot be integer" + } + if {[string length $existingKeyOrAlias]} { + set o_alias($newAlias) $existingKeyOrAlias + } else { + unset o_alias($newAlias) + } + } + method aliases {{key ""}} { + if {[string length $key]} { + set result [list] + foreach {n v} [array get o_alias] { + if {$v eq $key} { + lappend result $n $v + } + } + return $result + } else { + return [array get o_alias] + } + } + #if the supplied index is an alias, return the underlying key; else return the index supplied. + method realKey {idx} { + if {[catch {set o_alias($idx)} key]} { + return $idx + } else { + return $key + } + } + method add {value key} { + if {[string is integer -strict $key]} { + error "[self object] collection key must not be an integer. Use another structure if integer keys required" + } + if {[dict exists $o_data $key]} { + error "[self object] col_processors object error: key '$key' already exists in collection" + } + dict set o_data $key $value + return [expr {[dict size $o_data] - 1}] ;#return index of item + } + method remove {idx {endRange ""}} { + if {[string length $endRange]} { + error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" + } + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx+1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + error "[self object] no such index: '$idx' in this collection" + } + } + dict unset o_data $key + return + } + method clear {} { + set o_data [dict create] + return + } + method reverse {} { + set dictnew [dict create] + foreach k [lreverse [dict keys $o_data]] { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + return + } + #review - cmd as list vs cmd as script? + method map {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list {*}$cmd $v]] + } + return $seed + } + method objectmap {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list $v {*}$cmd]] + } + return $seed + } + } + +} + diff --git a/src/bootsupport/modules/punk/cap-0.1.0.tm b/src/bootsupport/modules/punk/cap-0.1.0.tm index 6749035a..34bed4c0 100644 --- a/src/bootsupport/modules/punk/cap-0.1.0.tm +++ b/src/bootsupport/modules/punk/cap-0.1.0.tm @@ -19,15 +19,171 @@ ## Requirements ##e.g package require frobz - +#concepts: +# A capability may be something like providing a folder of files, or just a data dictionary, and/or an API +# +# capability handler - a package/namespace which may provide validation and standardised ways of looking up provider data +# registered (or not) using register_capabilityname +# capability provider - a package which registers as providing one or more capablities. +# registered using register_package +# the capabilitylist is a list of 2-element lists where the first element is the capabilityname and the second element is a (possibly empty) dict of data relevant to that capability +# A capabilityname may appear multiple times. ie a package may register that it provides the capability with multiple datasets. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::cap { - variable pkgcap [dict create] + variable pkgcapsdeclared [dict create] + variable pkgcapsaccepted [dict create] variable caps [dict create] + if {[info commands [namespace current]::interface_caphandler.registry] eq ""} { + oo::class create [namespace current]::interface_caphandler.registry { + method pkg_register {pkg capname capdict fullcapabilitylist} { + #handler may override and return 0 (indicating don't register)e.g if pkg capdict data wasn't valid + #overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. + return 1 ;#default to permit + } + method pkg_unregister {pkg} { + return ;#unregistration return is ignored - review + } + } + + oo::class create [namespace current]::interface_capprovider.registration { + method get_declarations {} { + error "interface_capprovider.registration not implemented by provider" + } + } + oo::class create [namespace current]::interface_capprovider.provider { + method register {{capabilityname_glob *}} { + + } + method capabilities {} { + + } + } + } + #Not all capabilities have to be registered. + #A package registering as a provider using register_package can include capabilitynames in it's capabilitylist which have no associated capnamespace (handler). + #such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. + #we allow registering a capability with an empty handler (capnamespace) - but this means another handler could be registered later. + proc register_capabilityname {capname capnamespace} { + variable caps + variable pkgcapsdeclared + variable pkgcapsaccepted + if {$capnamespace ne ""} { + #normalize with leading :: in case caller passed in package name rather than fully qualified namespace + if {![string match ::* $capnamespace]} { + set capnamespace ::$capnamespace + } + } + #allow register of existing capname iff there is no current handler + #as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package + #we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers + if {[set hdlr [get_handler $capname]] ne ""} { + error "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" + } + #assert: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries. + dict set caps $capname handler $capnamespace + if {![dict exists $caps $capname providers]} { + dict set caps $capname providers [list] + } + if {[llength [set providers [dict get $caps $capname providers]]]} { + #some provider(s) were in place before the handler was registered + if {[set capreg [get_caphandler_registry $capname]] ne ""} { + foreach pkg $providers { + set fullcapabilitylist [dict get $pkgcapsdeclared $pkg] + foreach capspec $fullcapabilitylist { + lassign $capspec cn capdict + if {$cn ne $capname} { + continue + } + set do_register [$capreg pkg_register $pkg $capdict $fullcapabilitylist] + set list_accepted [dict get $pkgcapsaccepted $pkg] + if {$do_register} { + if {$capspec ni $list_accepted} { + dict lappend pkgcapsaccepted $pkg $capspec + } + } else { + set posn [lsearch $list_accepted $capspec] + if {$posn >=0} { + set list_accepted [lreplace $list_accepted $posn $posn] + dict set pkgcapsaccepted $pkg $list_accepted + } + } + } + #check if any accepted for this cap and remove from caps as necessary + set count 0 + foreach accepted_capspec [dict get $pkgcapsaccepted $pkg] { + if {[lindex $accepted_capspec 0] eq $capname} { + incr count + } + } + if {$count == 0} { + set pkgposn [lsearch $providers $pkg] + if {$pkgposn >= 0} { + set updated_providers [lreplace $providers $posn $posn] + dict set caps $capname providers $updated_providers + } + } + } + + } + + } + } + proc exists {capname} { + variable caps + return [dict exists $caps $capname] + } + proc has_handler {capname} { + variable caps + return [expr {[dict exists $caps $capname handler] && [dict get $caps $capname handler] ne ""}] + } + proc get_handler {capname} { + variable caps + if {[dict exists $caps $capname]} { + return [dict get $caps $capname handler] + } + return "" + } + + #dispatch + #proc call_handler {capname args} { + # if {[set handler [get_handler $capname]] eq ""} { + # error "punk::cap::call_handler $capname $args - no handler registered for capability $capname" + # } + # ${handler}::[lindex $args 0] {*}[lrange $args 1 end] + #} + proc call_handler {capname args} { + if {[set handler [get_handler $capname]] eq ""} { + error "punk::cap::call_handler $capname $args - no handler registered for capability $capname" + } + set obj ${handler}::$capname + $obj [lindex $args 0] {*}[lrange $args 1 end] + } + proc get_caphandler_registry {capname} { + set ns [get_handler $capname]::capsystem + if {[namespace exists ${ns}]} { + if {[info command ${ns}::caphandler.registry] ne ""} { + if {[info object isa object ${ns}::caphandler.registry]} { + return ${ns}::caphandler.registry + } + } + } + return "" + } + proc get_providers {capname} { + variable caps + if {[dict exists $caps $capname]} { + return [dict get $caps $capname providers] + } + return [list] + } + + #register package with arbitrary capnames from capabilitylist + #The registered pkg is a module that provides some service to that capname. Possibly just data members, that the capability will use. proc register_package {pkg capabilitylist} { - variable pkgcap + variable pkgcapsdeclared + variable pkgcapsaccepted variable caps if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] @@ -35,165 +191,209 @@ namespace eval punk::cap { #for each capability # - ensure 1st element is a single word # - ensure that if 2nd element (capdict) is present - it is dict shaped - foreach c $capabilitylist { - lassign $c capname capdict + foreach capspec $capabilitylist { + lassign $capspec capname capdict if {[llength $capname] !=1} { - error "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$c'" + error "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$capspec'" } if {[expr {[llength $capdict] %2 != 0}]} { - error "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$c'" + error "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$capspec'" } if {[dict exists $caps $capname]} { - set cap_pkgs [dict get $caps $capname] + set cap_pkgs [dict get $caps $capname providers] } else { + dict set caps $capname [dict create handler "" providers [list]] set cap_pkgs [list] } - if {$pkg ni $cap_pkgs} { - dict lappend caps $capname $pkg + #todo - if there's a caphandler - call it's init/validation callback for the pkg + set do_register 1 ;#default assumption unless vetoed by handler + if {[set capreg [get_caphandler_registry $capname]] ne ""} { + #Note that the interface_caphandler.registry instance must be able to handle multiple calls for same pkg + set do_register [$capreg pkg_register $pkg $capname $capdict $capabilitylist] + } + if {$do_register} { + if {$pkg ni $cap_pkgs} { + lappend cap_pkgs $pkg + dict set caps $capname providers $cap_pkgs + } + dict lappend pkgcapsaccepted $pkg $capspec ;#if pkg is being registered prior to handler-registration - the handler may undo this entry } } - dict set pkgcap $pkg $capabilitylist + #another call to register_pkg with same pkg may have been made (most likely with different capname) so we must append + #dict lappend pkgcapsdeclared $pkg $capabilitylist + if {[dict exists $pkgcapsdeclared $pkg]} { + set caps [dict get $pkgcapsdeclared $pkg] + lappend caps {*}$capabilitylist + dict set pkgcapsdeclared $pkg $caps + } else { + dict set pkgcapsdeclared $pkg $capabilitylist + } } + proc unregister_package {pkg} { + variable pkgcapsdeclared + variable caps + if {[string match ::* $pkg]} { + set pkg [string range $pkg 2 end] + } + if {[dict exists $pkgcapsdeclared $pkg]} { + #remove corresponding entries in caps + set capabilitylist [dict get $pkgcapsdeclared $pkg] + foreach c $capabilitylist { + set do_unregister 1 + lassign $c capname _capdict + set cap_info [dict get $caps $capname] + set pkglist [dict get $cap_info providers] + set posn [lsearch $pkglist $pkg] + if {$posn >= 0} { + if {[set capreg [get_caphandler_registry $capname]] ne ""} { + #review + # it seems not useful to allow the callback to block this unregister action + #the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter + #vetoing unregister would make this more complex for no particular advantage + #if per capability deregistration required this should probably be a separate thing (e.g disable_capability?) + $capreg pkg_unregister $pkg + } + set pkglist [lreplace $pkglist $posn $posn] + dict set caps $capname providers $pkglist + } + } + #delete the main registration record + dict unset pkgcapsdeclared $pkg + } + } + + #review promote/demote doesn't always make a lot of sense .. should possibly be per cap for multicap pkgs + #The idea is to provide a crude way to preference/depreference packages independently of order the packages were loaded + #e.g a caller or cap-handler can ascribe some meaning to the order of the 'providers' key returned from punk::cap::capabilities + #The order of providers will be the order the packages were loaded & registered + #the naming: "promote vs demote" operates on a latest-package-in-list has higher preference assumption (matching last pkg loaded) + #Each capability handler could implement specific preferencing methods if finer control needed. + #In some cases the preference/loading order may be inapplicable/irrelevant to a particular capability anyway. + #As this is just a basic mechanism, which can't support independent per-cap preferencing for multi-cap packages - + # it only allows putting the pkgs to the head or tail of the lists. + #Whether particular caps or users of caps do anything with this ordering is dependent on the cap-handler and/or calling code. proc promote_package {pkg} { - variable pkgcap + variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] } - if {![dict exists $pkgcap $pkg]} { + if {![dict exists $pkgcapsdeclared $pkg]} { error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" } - if {[dict size $pkgcap] > 1} { - set pkginfo [dict get $pkgcap $pkg] + if {[dict size $pkgcapsdeclared] > 1} { + set pkginfo [dict get $pkgcapsdeclared $pkg] #remove and re-add at end of dict - dict unset pkgcap $pkg - dict set pkgcap $pkg $pkginfo - foreach {cap cap_pkgs} $caps { + dict unset pkgcapsdeclared $pkg + dict set pkgcapsdeclared $pkg $pkginfo + dict for {cap cap_info} $caps { + set cap_pkgs [dict get $cap_info providers] if {$pkg in $cap_pkgs} { set posn [lsearch $cap_pkgs $pkg] if {$posn >=0} { #rewrite package list with pkg at tail of list for this capability set cap_pkgs [lreplace $cap_pkgs $posn $posn] lappend cap_pkgs $pkg - dict set caps $cap $cap_pkgs + dict set caps $cap providers $cap_pkgs } } } } } proc demote_package {pkg} { - variable pkgcap + variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] } - if {![dict exists $pkgcap $pkg]} { + if {![dict exists $pkgcapsdeclared $pkg]} { error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" } - if {[dict size $pkgcap] > 1} { - set pkginfo [dict get $pkgcap $pkg] + if {[dict size $pkgcapsdeclared] > 1} { + set pkginfo [dict get $pkgcapsdeclared $pkg] #remove and re-add at start of dict - dict unset pkgcap $pkg - dict set pkgcap $pkg $pkginfo - set pkgcap [dict merge [dict create $pkg $pkginfo] $pkgcap] - foreach {cap cap_pkgs} $caps { + dict unset pkgcapsdeclared $pkg + dict set pkgcapsdeclared $pkg $pkginfo + set pkgcapsdeclared [dict merge [dict create $pkg $pkginfo] $pkgcapsdeclared] + dict for {cap cap_info} $caps { + set cap_pkgs [dict get $cap_info providers] if {$pkg in $cap_pkgs} { set posn [lsearch $cap_pkgs $pkg] if {$posn >=0} { #rewrite package list with pkg at head of list for this capability set cap_pkgs [lreplace $cap_pkgs $posn $posn] set cap_pkgs [list $pkg {*}$cap_pkgs] - dict set caps $cap $cap_pkgs + dict set caps $cap providers $cap_pkgs } } } } } - proc unregister_package {pkg} { - variable pkgcap - variable caps + proc pkgcap {pkg} { + variable pkgcapsdeclared + variable pkgcapsaccepted if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] } - if {[dict exists $pkgcap $pkg]} { - #remove corresponding entries in caps - set capabilitylist [dict get $pkgcap $pkg] - foreach c $capabilitylist { - lassign $c capname _capdict - set pkglist [dict get $caps $capname] - set posn [lsearch $pkglist $pkg] - if {$posn >= 0} { - set pkglist [lreplace $pkglist $posn $posn] - dict set caps $capname $pkglist - } + if {[dict exists $pkgcapsdeclared $pkg]} { + set accepted "" + if {[dict exists $pkgcapsaccepted $pkg]} { + set accepted [dict get $pkgcapsaccepted $pkg] } - #delete the main registration record - dict unset pkgcap $pkg - } - } - proc registered_package {pkg} { - variable pkgcap - if {[string match ::* $pkg]} { - set pkg [string range $pkg 2 end] - } - if {[dict exists $pkgcap $pkg]} { - return [dict get $pkgcap $pkg] + return [dict create declared [dict get $pkgcapsdeclared $pkg] accepted $accepted] } else { return } } - proc registered_packages {} { - variable pkgcap - return $pkgcap + proc pkgcaps {} { + variable pkgcapsdeclared + variable pkgcapsaccepted + set result [dict create] + foreach {pkg capsdeclared} $pkgcapsdeclared { + set accepted "" + if {[dict exists $pkgcapsaccepted $pkg]} { + set accepted [dict get $pkgcapsaccepted $pkg] + } + dict set result $pkg declared $capsdeclared + dict set result $pkg accepted $accepted + } + return $result } + proc capability {capname} { + variable caps + if {[dict exists $caps $capname]} { + return [dict get $caps $capname] + } + return "" + } proc capabilities {{glob *}} { variable caps - set keys [lsort [dict keys $caps $glob]] + set capnames [lsort [dict keys $caps $glob]] set cap_list [list] - foreach k $keys { - lappend cap_list [list $k [dict get $caps $k]] + foreach capname $capnames { + lappend cap_list [list $capname [dict get $caps $capname]] } return $cap_list } - namespace eval templates { - #return a dict keyed on folder with source pkg as value - proc folders {} { - package require punk::cap - set caplist [punk::cap::capabilities templates] - # e.g {templates {punk::mix::templates ::somepkg}} - set templates_record [lindex $caplist 0] - set pkgs [lindex $templates_record 1] - - set folderdict [dict create] - foreach pkg $pkgs { - set caplist [punk::cap::registered_package $pkg] - set templates_entries [lsearch -all -inline -index 0 $caplist templates] ;#we generally expect only one - but if multiple exist - use them - foreach templates_info $templates_entries { - lassign $templates_info _templates templates_dict - if {[dict exists $templates_dict relpath]} { - set provide_statement [package ifneeded $pkg [package require $pkg]] - set tmfile [lindex $provide_statement end] - #set tmdir [file dirname [lindex $provide_statement end]] - set tpath [file normalize [file join $tmfile [dict get $templates_dict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder - #relpath relative to file is important for tm files that are zip/tar based containers - if {[file isdirectory $tpath]} { - dict set folderdict $tpath [list source $pkg sourcetype package] - } else { - puts stderr "punk::cap::templates::folders WARNING - unable to determine base folder for package '$pkg' which is registered with punk::mix as a provider of 'templates' capability" - } - } else { - puts stderr "punk::cap::templates::folders WARNING - registered pkg 'pkg' has capability 'templates' but no 'relpath' key - unable to use as source of templates" - } - } + proc capabilitynames {{glob *}} { + variable caps + return [lsort [dict keys $caps $glob]] + } + #return only those capnames which have at least one provider + proc capabilitynames_provided {{glob *}} { + variable caps + set keys [lsort [dict keys $caps $glob]] + set cap_list [list] + foreach k $keys { + if {[llength [dict get $caps $k providers]] > 0} { + lappend cap_list $k } - return $folderdict } - - - + return $cap_list } + } diff --git a/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm b/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm new file mode 100644 index 00000000..8fdce944 --- /dev/null +++ b/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm @@ -0,0 +1,52 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -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) 2023 +# +# @@ Meta Begin +# Application punk::cap::handlers::caphandler 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::cap::handlers::caphandler { + + + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::cap::handlers::caphandler [namespace eval punk::cap::handlers::caphandler { + variable pkg punk::cap::handlers::caphandler + variable version + set version 0.1.0 +}] +return \ No newline at end of file diff --git a/src/bootsupport/modules/punk/cap/handlers/scriptlibs-0.1.0.tm b/src/bootsupport/modules/punk/cap/handlers/scriptlibs-0.1.0.tm new file mode 100644 index 00000000..8298ec18 --- /dev/null +++ b/src/bootsupport/modules/punk/cap/handlers/scriptlibs-0.1.0.tm @@ -0,0 +1,52 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -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) 2023 +# +# @@ Meta Begin +# Application punk::cap::handlers::scriptlibs 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::cap::handlers::scriptlibs { + + + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::cap::handlers::scriptlibs [namespace eval punk::cap::handlers::scriptlibs { + variable pkg punk::cap::handlers::scriptlibs + variable version + set version 0.1.0 +}] +return \ No newline at end of file diff --git a/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm b/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm new file mode 100644 index 00000000..28a25e6f --- /dev/null +++ b/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm @@ -0,0 +1,127 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -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) 2023 +# +# @@ Meta Begin +# Application punk::cap::handlers::templates 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#register using: +# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates + +#By convention and for consistency, we don't register here during package loading - but require the calling app to do it. +# (even if it tends to be done immediately after package require anyway) +# registering capability handlers can involve validating existing provider data and is best done explicitly as required. +# It is also possible for a capability handler to be registered to handle more than one capabilityname + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::cap::handlers::templates { + namespace eval capsystem { + #interfaces for punk::cap to call into + if {[info commands caphandler.registry] eq ""} { + punk::cap::interface_caphandler.registry create caphandler.registry + oo::objdefine caphandler.registry { + method pkg_register {pkg capname capdict caplist} { + #caplist may not be complete set - which somewhat reduces its utility here regarding any decisions based on the context of this capname/capdict (review - remove this arg?) + if {![dict exists $capdict relpath]} { + puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing 'relpath' key" + return 0 + } + set provide_statement [package ifneeded $pkg [package require $pkg]] + set tmfile [lindex $provide_statement end] + if {![file exists $tmfile]} { + puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" + return 0 + } + set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder + if {![file isdirectory $tpath]} { + puts stderr "punk::cap::handlers::templates::capsystem pkg_register WARNING - unable to validate relpath location [dict get $capdict relpath] ($tpath) for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" + } + if {$capname ni $::punk::cap::handlers::templates::handled_caps} { + lappend ::punk::cap::handlers::templates::handled_caps $capname + } + if {[info commands punk::cap::handlers::templates::$capname] eq ""} { + punk::cap::handlers::templates::api create ::punk::cap::handlers::templates::$capname $capname + } + set cname [string map [list . _] $capname] + upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders + dict lappend pfolders $pkg $tpath + return 1 + } + method pkg_unregister {pkg} { + upvar ::punk::cap::handlers::templates::handled_caps hcaps + foreach capname $hcaps { + set cname [string map [list . _] $capname] + upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders + dict unset pfolders $pkg + #destroy api objects? + } + } + } + } + } + + variable handled_caps [list] + #variable pkg_folders [dict create] + + # -- --- --- --- --- --- --- + #handler api for clients of this capability - called via punk::cap::call_handler ?args? + # -- --- --- --- --- --- --- + namespace export * + + oo::class create api { + #return a dict keyed on folder with source pkg as value + constructor {capname} { + variable capabilityname + variable cname + set cname [string map [list . _] $capname] + set capabilityname $capname + } + method folders {} { + variable capabilityname + variable cname + upvar punk::cap::handlers::templates::pkg_folders_$cname pkg_folders + package require punk::cap + set capinfo [punk::cap::capability $capabilityname] + # e.g {punk.templates {handler punk::mix::templates providers ::somepkg}} + + #use the order of pkgs as registered with punk::cap - may have been modified with punk::cap::promote_package/demote_package + set pkgs [dict get $capinfo providers] + set folderdict [dict create] + foreach pkg $pkgs { + foreach pfolder [dict get $pkg_folders $pkg] { + dict set folderdict $pfolder [list source $pkg sourcetype package] + } + } + return $folderdict + } + } + + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::cap::handlers::templates [namespace eval punk::cap::handlers::templates { + variable pkg punk::cap::handlers::templates + variable version + set version 0.1.0 +}] +return \ No newline at end of file diff --git a/src/bootsupport/modules/punk/mix-0.2.tm b/src/bootsupport/modules/punk/mix-0.2.tm index 2988b428..d09dfca8 100644 --- a/src/bootsupport/modules/punk/mix-0.2.tm +++ b/src/bootsupport/modules/punk/mix-0.2.tm @@ -1,6 +1,12 @@ package require punk::cap -package require punk::mix::templates ;#registers 'templates' capability with punk::cap + +package require punk::cap::handlers::templates ;#handler for templates cap +punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates + +package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap +#punk::mix::templates::provider register * + package require punk::mix::base package require punk::mix::cli diff --git a/src/bootsupport/modules/punk/mix/base-0.1.tm b/src/bootsupport/modules/punk/mix/base-0.1.tm index 0f131936..fcfaf56b 100644 --- a/src/bootsupport/modules/punk/mix/base-0.1.tm +++ b/src/bootsupport/modules/punk/mix/base-0.1.tm @@ -1,904 +1,908 @@ -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] ;#dependency on punk pipeline/patternmatching system - lassign [_split_args $args] _opts opts _args args - if {[dict exists $opts -extension]} { - set extension [dict get $opts -extension] - } else { - set extension "" - } - #--------- - - uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] - } - proc _cli {args} { - #--------- - #extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system - lassign [_split_args $args] _opts opts _args args - if {[dict exists $opts -extension]} { - set extension [dict get $opts -extension] - } else { - set extension "" - } - #--------- - if {![string length $extension]} { - set extension [namespace qualifiers [lindex [info level -1] 0]] - } - #puts stderr "punk::mix::base extension: [string trimleft $extension :]" - if {![string length $extension]} { - #if still no extension - must have been called dirctly as punk::mix::base::_cli - if {![llength $args]} { - set args "help" - } - set extension [namespace current] - } - 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] ;#dependency on punk pipeline/patternmatching system - lassign [_split_args $args] _opts opts _args args - if {[dict exists $opts -extension]} { - set extension [dict get $opts -extension] - } else { - set extension "" - } - #--------- - - 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 "_redirected $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 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] ;#dependency on punk pipeline/patternmatching system - lassign [_split_args $args] _opts opts _args args - if {[dict exists $opts -extension]} { - set extension [dict get $opts -extension] - } else { - set extension "" - } - #--------- - 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 - #' ``` - #' - #' - - - #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> " opts $opts] - } - if {$ftype ni [list file directory]} { - #review - links? - error "cksum_path error file type '$ftype' not supported" - } - - - set opt_cksum_algorithm [dict get $opts -cksum_algorithm] - if {$opt_cksum_algorithm ni [cksum_algorithms]} { - return [list error unsupported_cksum_algorithm cksum "" opts $opts] - } - set opt_cksum_acls [dict get $opts -cksum_acls] - if {$opt_cksum_acls} { - puts stderr "cksum_path is not yet able to cksum ACLs" - return - } - - set opt_cksum_meta [dict get $opts -cksum_meta] - set opt_use_tar [dict get $opts -cksum_usetar] - if {$ftype eq "file"} { - if {$opt_use_tar eq "auto"} { - if {$opt_cksum_meta eq "1"} { - set opt_use_tar 1 - } else { - #prefer no tar if meta not required - faster/simpler - #meta == auto or 0 - set opt_cksum_meta 0 - set opt_use_tar 0 - } - } elseif {$opt_use_tar eq "0"} { - if {$opt_cksum_meta eq "1"} { - puts stderr "cksum_path doesn't yet support a non-tar cksum with metadata for a file" - return [list error unsupported_meta_without_tar cksum "" opts $opts] - } else { - #meta == auto or 0 - set opt_cksum_meta 0 - } - } else { - #tar == 1 - if {$opt_cksum_meta eq "0"} { - puts stderr "cksum_path doesn't yet support a tar cksum without metadata for a file" - return [list error unsupported_tar_without_meta cksum "" opts $opts] - } else { - #meta == auto or 1 - set opt_cksum_meta 1 - } - } - } elseif {$ftype eq "directory"} { - if {$opt_use_tar eq "auto"} { - if {$opt_cksum_meta in [list "auto" "1"]} { - set opt_use_tar 1 - set opt_cksum_meta 1 - } else { - puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto" - return [list error unsupported_directory_cksum_without_meta cksum "" opts $opts] - } - } elseif {$opt_use_tar eq "0"} { - puts stderr "cksum_path doesn't yet support a cksum of a folder structure without tar. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" - return [list error unsupported_directory_cksum_without_tar cksum "" opts $opts] - } else { - #tar 1 - if {$opt_cksum_meta eq "0"} { - puts stderr "cksum_path doesn't yet support a tar checksum of a folder structure without metadat. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" - return [list error unsupported_without_meta cksum "" opts $opts] - } else { - #meta == auto or 1 - set opt_cksum_meta 1 - } - } - } - - dict set opts_actual -cksum_meta $opt_cksum_meta - dict set opts_actual -cksum_usetar $opt_use_tar - - - if {$opt_use_tar} { - package require tar ;#from tcllib - } - - if {$path eq $base} { - #attempting to cksum at root/volume level of a filesystem.. extra work - #This needs fixing for general use.. not necessarily just for project repos - puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" - return [list error unsupported_path opts $opts] - } - - if {$opt_cksum_algorithm eq "sha1"} { - package require sha1 - set cksum_command [list sha1::sha1 -hex -file] - } elseif {$opt_cksum_algorithm in [list "sha2" "sha256"]} { - package require sha256 - set cksum_command [list sha2::sha256 -hex -file] - } elseif {$opt_cksum_algorithm eq "md5"} { - package require md5 - set cksum_command [list md5::md5 -hex -file] - } elseif {$opt_cksum_algorithm eq "cksum"} { - package require cksum ;#tcllib - set cksum_command [list crc::cksum -format 0x%X -file] - } elseif {$opt_cksum_algorithm eq "adler32"} { - set cksum_command [list cksum_adler32_file] - } elseif {$opt_cksum_algorithm in [list "sha3" "sha3-256"]} { - #todo - replace with something that doesn't call another process - #set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] - set cksum_command [list $sha3_implementation 256] - } elseif {$opt_cksum_algorithm in [list "sha3-224" "sha3-384" "sha3-512"]} { - set bits [lindex [split $opt_cksum_algorithm -] 1] - #set cksum_command [list apply {{bits file} {lindex [exec fossil sha3sum -$bits $file] 0}} $bits] - set cksum_command [list $sha3_implementation $bits] - } - - set cksum "" - if {$opt_use_tar != 0} { - set target [file tail $path] - set tmplocation [punk::mix::util::tmpdir] - set archivename $tmplocation/[punk::mix::util::tmpfile].tar - - cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) - - #temp emission to stdout.. todo - repl telemetry channel - puts stdout "cksum_path: creating temporary tar archive at: $archivename .." - tar::create $archivename $target - if {$ftype eq "file"} { - set sizeinfo "(size [file size $target])" - } else { - set sizeinfo "(file type $ftype - size unknown)" - } - puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." - set cksum [{*}$cksum_command $archivename] - #puts stdout "cksum_path: cleaning up.. " - file delete -force $archivename - cd $startdir - - } else { - #todo - if {$ftype eq "file"} { - if {$opt_cksum_meta} { - return [list error unsupported_opts_combo cksum "" opts $opts] - } else { - set cksum [{*}$cksum_command $path] - } - } else { - error "cksum_path unsupported $opts for path type [file type $path]" - } - } - set result [dict create] - dict set result cksum $cksum - dict set result opts $opts_actual - return $result - } - - #dict_path_cksum keyed on path - with value as a dict that must contain cksum key - but can contain other keys - #e.g -cksum_usetar which is one of the keys understood by the punk::mix::base::lib::cksum_path function - or unrelated keys which will also be passed through - #cksum only calculated for keys in dict where cksum is empty - ie return same dict but with empty cksums filled out. - #base can be empty string in which case paths must be absolute - proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { - if {$base eq ""} { - set error_paths [list] - dict for {path pathinfo} $dict_path_cksum { - if {[file pathtype $path] ne "absolute"} { - lappend error_paths $path - } - } - if {[llength $error_paths]} { - puts stderr "get_relativecksums_from_base_and_relativepathdict has empty base - and non-absolute paths in the supplied checksum dict - aborting" - puts stderr "error_paths: $error_paths" - error "fill_relativecksums_from_base_and_relativepathdict error: non-absolute paths when base empty. $error_paths" - } - } else { - if {[file pathtype $base] ne "absolute"} { - error "fill_relativecksums_from_base_and_relativepathdict error: base supplied but was not absolute path. $base" - } - #conversely now we have a base - so we require all paths are relative. - #We will ignore/disallow volume-relative - as these shouldn't be used here either - set error_paths [list] - dict for {path pathinfo} $dict_path_cksum { - if {[file pathtype $path] ne "relative"} { - lappend error_paths $path - } - } - if {[llength $error_paths]} { - puts stderr "fill_relativecksums_from_base_and_relativepathdict has a supplied absolute base path, but some of the paths in the supplied dict are not relative - aborting" - error "fill_relativecksums_from_base_and_relativepathdict error: non-relative paths when base supplied. $error_paths" - } - } - - - dict for {path pathinfo} $dict_path_cksum { - if {![dict exists $pathinfo cksum]} { - dict set pathinfo cksum "" - } else { - if {[dict get $pathinfo cksum] ne "" && ![cksum_is_tag [dict get $pathinfo cksum]]} { - continue ;#already filled with non-tag value - } - } - if {$base ne ""} { - set fullpath [file join $base $path] - } else { - set fullpath $path - } - - set ckopts [cksum_filter_opts {*}$pathinfo] - - if {![file exists $fullpath]} { - dict set dict_path_cksum $path cksum "" - } else { - set ckinfo [cksum_path $fullpath {*}$ckopts] - dict set dict_path_cksum $path cksum [dict get $ckinfo cksum] - dict set dict_path_cksum $path cksum_all_opts [dict get $ckinfo opts] - if {[dict exists $ckinfo error]} { - dict set dict_path_cksum $path cksum_error [dict get $ckinfo error] - } - } - } - - return $dict_path_cksum - } - #whether cksum is e.g - proc cksum_is_tag {cksum} { - expr {[string index $cksum 0] eq "<" && [string index $cksum end] eq ">"} - } - proc cksum_filter_opts {args} { - set ck_opt_names [dict keys [cksum_default_opts]] - set ck_opts [dict create] - dict for {k v} $args { - if {$k in $ck_opt_names} { - dict set ck_opts $k $v - } - } - return $ck_opts - } - - #convenience so caller doesn't have to pre-calculate the relative path from the base - #Note semantic difference from fill_relativecksums_from_base_and_relativepathdict (hence get_ vs fill_) - #Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will ignore valid-looking prefilled cksum values - #base is the presumed location to store the checksum file. The caller should retain (normalize if relative) - proc get_relativecksum_from_base {base specifiedpath args} { - if {$base ne ""} { - #targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it - #we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix - if {[file pathtype $specifiedpath] eq "relative"} { - if {[file pathtype $base] eq "relative"} { - set normbase [file normalize $base] - set normtarg [file normalize [file join $normbase $specifiedpath]] - set targetpath $normtarg - set storedpath [punk::mix::util::path_relative $normbase $normtarg] - } else { - set targetpath [file join $base $specifiedpath] - set storedpath $specifiedpath - } - } else { - #specifed absolute - if {[file pathtype $base] eq "relative"} { - #relative to cwd or to specifiedpath? For consistency it should arguably be cwd but a case could be made that when one path is relative it is in reference to the other - #there is a strong possibility that allowing this combination will cause confusion - better to disallow - error "get_relativecksum_from_base error: disallowed pathtype combination. Base must be empty or absolute when specified path is absolute" - } - #both absolute - compute relative path if they share a common prefix - set commonprefix [punk::mix::util::path_common_prefix $base $specifiedpath] - if {$commonprefix eq ""} { - #absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base - error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" - } - set targetpath $specifiedpath - set storedpath [punk::mix::util::path_relative $base $specifiedpath] - - } - } else { - if {[file type $specifiedpath] eq "relative"} { - #if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage - set targetpath [file normalize $specifiedpath] - set storedpath $targetpath - } else { - set targetpath $specifiedpath - set storedpath $targetpath - } - } - - # - #NOTE: specifiedpath can be a relative path (to cwd) when base is empty - #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc - #possibly also: base: somewhere targetpath: ../elsewhere/etc - # - #todo - write tests - - - if {([llength $args] % 2) != 0} { - error "get_relativecksum_from_base error. args supplied must be in the form of key-value pairs. received '$args' " - } - if {[dict exists $args cksum]} { - if {[dict get $args cksum] ne "" && ![cksum_is_tag [dict get $args cksum]]} { - error "get_relativecksum_from_base called with existing cksum value (and is not a tag or empty-value to be replaced) cksum: [dict get $args cksum] Set cksum to be empty, any tag such as or remove the key and try again." - } - } - - - set ckopts [cksum_filter_opts {*}$args] - set ckinfo [cksum_path $targetpath {*}$ckopts] - - set keyvals $args - dict set keyvals cksum [dict get $ckinfo cksum] - dict set keyvals cksum_all_opts [dict get $ckinfo opts] - if {[dict exists $ckinfo error]} { - dict set keyvals cksum_error [dict get $ckinfo error] - } - - #set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop - #storedpath is relative if possible - return [dict create $storedpath $keyvals] - } - - #calculate the runtime checksum and vfs checksums - proc get_all_vfs_build_cksums {path} { - set buildfolder [get_build_workdir $path] - set cksum_base_folder [file dirname $buildfolder] ;#this is the /src folder - a reasonable base for our vfs cksums - set dict_cksums [dict create] - - set buildrelpath [punk::repo::path_strip_alreadynormalized_prefixdepth $buildfolder $cksum_base_folder] - set vfs_tail_list [glob -nocomplain -dir $cksum_base_folder -type d -tails *.vfs] - - foreach vfstail $vfs_tail_list { - set vname [file rootname $vfstail] - dict set dict_cksums $vfstail [list cksum ""] - dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] - } - - set fullpath_buildruntime $buildfolder/buildruntime.exe - - set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] - set ck [dict get $ckinfo_buildruntime cksum] - - - set relpath [file join $buildrelpath "buildruntime.exe"] - dict set dict_cksums $relpath [list cksum $ck] - - set dict_cksums [fill_relativecksums_from_base_and_relativepathdict $cksum_base_folder $dict_cksums] - - return $dict_cksums - } - - proc get_vfs_build_cksums_stored {vfsfolder} { - set vfscontainer [file dirname $vfsfolder] - set buildfolder $vfscontainer/_build - set vfs [file tail $vfsfolder] - set vname [file rootname $vfs] - set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] - set ckfile $buildfolder/$vname.cksums - if {[file exists $ckfile]} { - set data [punk::mix::util::fcat -translation binary $ckfile] - foreach ln [split $data \n] { - if {[string trim $ln] eq ""} {continue} - lassign $ln path cksum - dict set dict_vfs $path $cksum - } - } - return $dict_vfs - } - proc get_all_build_cksums_stored {path} { - set buildfolder [get_build_workdir $path] - - set vfscontainer [file dirname $buildfolder] - set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] - set dict_cksums [dict create] - foreach vfs $vfslist { - set vname [file rootname $vfs] - set dict_vfs [get_vfs_build_cksums_stored $vfscontainer/$vfs] - - dict set dict_cksums $vname $dict_vfs - } - return $dict_cksums - } - - proc store_vfs_build_cksums {vfsfolder} { - if {![file isdirectory $vfsfolder]} { - error "Unable to find supplied vfsfolder: $vfsfolder" - } - set vfscontainer [file dirname $vfsfolder] - set buildfolder $vfscontainer/_build - set dict_vfs [get_vfs_build_cksums $vfsfolder] - set data "" - dict for {path cksum} $dict_vfs { - append data "$path $cksum" \n - } - set fd [open $buildfolder/$vname.cksums w] - chan configure $fd -translation binary - puts $fd $data - close $fd - return $dict_vfs - } - - - - } -} +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] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + + uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] + } + proc _cli {args} { + #--------- + #extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + if {![string length $extension]} { + set extension [namespace qualifiers [lindex [info level -1] 0]] + } + #puts stderr "punk::mix::base extension: [string trimleft $extension :]" + if {![string length $extension]} { + #if still no extension - must have been called dirctly as punk::mix::base::_cli + if {![llength $args]} { + set args "help" + } + set extension [namespace current] + } + 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] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + + 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 "_redirected $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 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] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + 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 + #' ``` + #' + #' + + + #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> " opts $opts] + } + if {$ftype ni [list file directory]} { + #review - links? + error "cksum_path error file type '$ftype' not supported" + } + + + set opt_cksum_algorithm [dict get $opts -cksum_algorithm] + if {$opt_cksum_algorithm ni [cksum_algorithms]} { + return [list error unsupported_cksum_algorithm cksum "" opts $opts] + } + set opt_cksum_acls [dict get $opts -cksum_acls] + if {$opt_cksum_acls} { + puts stderr "cksum_path is not yet able to cksum ACLs" + return + } + + set opt_cksum_meta [dict get $opts -cksum_meta] + set opt_use_tar [dict get $opts -cksum_usetar] + if {$ftype eq "file"} { + if {$opt_use_tar eq "auto"} { + if {$opt_cksum_meta eq "1"} { + set opt_use_tar 1 + } else { + #prefer no tar if meta not required - faster/simpler + #meta == auto or 0 + set opt_cksum_meta 0 + set opt_use_tar 0 + } + } elseif {$opt_use_tar eq "0"} { + if {$opt_cksum_meta eq "1"} { + puts stderr "cksum_path doesn't yet support a non-tar cksum with metadata for a file" + return [list error unsupported_meta_without_tar cksum "" opts $opts] + } else { + #meta == auto or 0 + set opt_cksum_meta 0 + } + } else { + #tar == 1 + if {$opt_cksum_meta eq "0"} { + puts stderr "cksum_path doesn't yet support a tar cksum without metadata for a file" + return [list error unsupported_tar_without_meta cksum "" opts $opts] + } else { + #meta == auto or 1 + set opt_cksum_meta 1 + } + } + } elseif {$ftype eq "directory"} { + if {$opt_use_tar eq "auto"} { + if {$opt_cksum_meta in [list "auto" "1"]} { + set opt_use_tar 1 + set opt_cksum_meta 1 + } else { + puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto" + return [list error unsupported_directory_cksum_without_meta cksum "" opts $opts] + } + } elseif {$opt_use_tar eq "0"} { + puts stderr "cksum_path doesn't yet support a cksum of a folder structure without tar. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" + return [list error unsupported_directory_cksum_without_tar cksum "" opts $opts] + } else { + #tar 1 + if {$opt_cksum_meta eq "0"} { + puts stderr "cksum_path doesn't yet support a tar checksum of a folder structure without metadat. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" + return [list error unsupported_without_meta cksum "" opts $opts] + } else { + #meta == auto or 1 + set opt_cksum_meta 1 + } + } + } + + dict set opts_actual -cksum_meta $opt_cksum_meta + dict set opts_actual -cksum_usetar $opt_use_tar + + + if {$opt_use_tar} { + package require tar ;#from tcllib + } + + if {$path eq $base} { + #attempting to cksum at root/volume level of a filesystem.. extra work + #This needs fixing for general use.. not necessarily just for project repos + puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" + return [list error unsupported_path opts $opts] + } + + if {$opt_cksum_algorithm eq "sha1"} { + package require sha1 + set cksum_command [list sha1::sha1 -hex -file] + } elseif {$opt_cksum_algorithm in [list "sha2" "sha256"]} { + package require sha256 + set cksum_command [list sha2::sha256 -hex -file] + } elseif {$opt_cksum_algorithm eq "md5"} { + package require md5 + set cksum_command [list md5::md5 -hex -file] + } elseif {$opt_cksum_algorithm eq "cksum"} { + package require cksum ;#tcllib + set cksum_command [list crc::cksum -format 0x%X -file] + } elseif {$opt_cksum_algorithm eq "adler32"} { + set cksum_command [list cksum_adler32_file] + } elseif {$opt_cksum_algorithm in [list "sha3" "sha3-256"]} { + #todo - replace with something that doesn't call another process + #set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] + set cksum_command [list $sha3_implementation 256] + } elseif {$opt_cksum_algorithm in [list "sha3-224" "sha3-384" "sha3-512"]} { + set bits [lindex [split $opt_cksum_algorithm -] 1] + #set cksum_command [list apply {{bits file} {lindex [exec fossil sha3sum -$bits $file] 0}} $bits] + set cksum_command [list $sha3_implementation $bits] + } + + set cksum "" + if {$opt_use_tar != 0} { + set target [file tail $path] + set tmplocation [punk::mix::util::tmpdir] + set archivename $tmplocation/[punk::mix::util::tmpfile].tar + + cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) + + #temp emission to stdout.. todo - repl telemetry channel + puts stdout "cksum_path: creating temporary tar archive at: $archivename .." + tar::create $archivename $target + if {$ftype eq "file"} { + set sizeinfo "(size [file size $target])" + } else { + set sizeinfo "(file type $ftype - size unknown)" + } + puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." + set cksum [{*}$cksum_command $archivename] + #puts stdout "cksum_path: cleaning up.. " + file delete -force $archivename + cd $startdir + + } else { + #todo + if {$ftype eq "file"} { + if {$opt_cksum_meta} { + return [list error unsupported_opts_combo cksum "" opts $opts] + } else { + set cksum [{*}$cksum_command $path] + } + } else { + error "cksum_path unsupported $opts for path type [file type $path]" + } + } + set result [dict create] + dict set result cksum $cksum + dict set result opts $opts_actual + return $result + } + + #dict_path_cksum keyed on path - with value as a dict that must contain cksum key - but can contain other keys + #e.g -cksum_usetar which is one of the keys understood by the punk::mix::base::lib::cksum_path function - or unrelated keys which will also be passed through + #cksum only calculated for keys in dict where cksum is empty - ie return same dict but with empty cksums filled out. + #base can be empty string in which case paths must be absolute + proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { + if {$base eq ""} { + set error_paths [list] + dict for {path pathinfo} $dict_path_cksum { + if {[file pathtype $path] ne "absolute"} { + lappend error_paths $path + } + } + if {[llength $error_paths]} { + puts stderr "get_relativecksums_from_base_and_relativepathdict has empty base - and non-absolute paths in the supplied checksum dict - aborting" + puts stderr "error_paths: $error_paths" + error "fill_relativecksums_from_base_and_relativepathdict error: non-absolute paths when base empty. $error_paths" + } + } else { + if {[file pathtype $base] ne "absolute"} { + error "fill_relativecksums_from_base_and_relativepathdict error: base supplied but was not absolute path. $base" + } + #conversely now we have a base - so we require all paths are relative. + #We will ignore/disallow volume-relative - as these shouldn't be used here either + set error_paths [list] + dict for {path pathinfo} $dict_path_cksum { + if {[file pathtype $path] ne "relative"} { + lappend error_paths $path + } + } + if {[llength $error_paths]} { + puts stderr "fill_relativecksums_from_base_and_relativepathdict has a supplied absolute base path, but some of the paths in the supplied dict are not relative - aborting" + error "fill_relativecksums_from_base_and_relativepathdict error: non-relative paths when base supplied. $error_paths" + } + } + + + dict for {path pathinfo} $dict_path_cksum { + if {![dict exists $pathinfo cksum]} { + dict set pathinfo cksum "" + } else { + if {[dict get $pathinfo cksum] ne "" && ![cksum_is_tag [dict get $pathinfo cksum]]} { + continue ;#already filled with non-tag value + } + } + if {$base ne ""} { + set fullpath [file join $base $path] + } else { + set fullpath $path + } + + set ckopts [cksum_filter_opts {*}$pathinfo] + + if {![file exists $fullpath]} { + dict set dict_path_cksum $path cksum "" + } else { + set ckinfo [cksum_path $fullpath {*}$ckopts] + dict set dict_path_cksum $path cksum [dict get $ckinfo cksum] + dict set dict_path_cksum $path cksum_all_opts [dict get $ckinfo opts] + if {[dict exists $ckinfo error]} { + dict set dict_path_cksum $path cksum_error [dict get $ckinfo error] + } + } + } + + return $dict_path_cksum + } + #whether cksum is e.g + proc cksum_is_tag {cksum} { + expr {[string index $cksum 0] eq "<" && [string index $cksum end] eq ">"} + } + proc cksum_filter_opts {args} { + set ck_opt_names [dict keys [cksum_default_opts]] + set ck_opts [dict create] + dict for {k v} $args { + if {$k in $ck_opt_names} { + dict set ck_opts $k $v + } + } + return $ck_opts + } + + #convenience so caller doesn't have to pre-calculate the relative path from the base + #Note semantic difference from fill_relativecksums_from_base_and_relativepathdict (hence get_ vs fill_) + #Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will ignore valid-looking prefilled cksum values + #base is the presumed location to store the checksum file. The caller should retain (normalize if relative) + proc get_relativecksum_from_base {base specifiedpath args} { + if {$base ne ""} { + #targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it + #we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix + if {[file pathtype $specifiedpath] eq "relative"} { + if {[file pathtype $base] eq "relative"} { + set normbase [file normalize $base] + set normtarg [file normalize [file join $normbase $specifiedpath]] + set targetpath $normtarg + set storedpath [punk::mix::util::path_relative $normbase $normtarg] + } else { + set targetpath [file join $base $specifiedpath] + set storedpath $specifiedpath + } + } else { + #specifed absolute + if {[file pathtype $base] eq "relative"} { + #relative to cwd or to specifiedpath? For consistency it should arguably be cwd but a case could be made that when one path is relative it is in reference to the other + #there is a strong possibility that allowing this combination will cause confusion - better to disallow + error "get_relativecksum_from_base error: disallowed pathtype combination. Base must be empty or absolute when specified path is absolute" + } + #both absolute - compute relative path if they share a common prefix + set commonprefix [punk::mix::util::path_common_prefix $base $specifiedpath] + if {$commonprefix eq ""} { + #absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base + error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" + } + set targetpath $specifiedpath + set storedpath [punk::mix::util::path_relative $base $specifiedpath] + + } + } else { + if {[file type $specifiedpath] eq "relative"} { + #if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage + set targetpath [file normalize $specifiedpath] + set storedpath $targetpath + } else { + set targetpath $specifiedpath + set storedpath $targetpath + } + } + + # + #NOTE: specifiedpath can be a relative path (to cwd) when base is empty + #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc + #possibly also: base: somewhere targetpath: ../elsewhere/etc + # + #todo - write tests + + + if {([llength $args] % 2) != 0} { + error "get_relativecksum_from_base error. args supplied must be in the form of key-value pairs. received '$args' " + } + if {[dict exists $args cksum]} { + if {[dict get $args cksum] ne "" && ![cksum_is_tag [dict get $args cksum]]} { + error "get_relativecksum_from_base called with existing cksum value (and is not a tag or empty-value to be replaced) cksum: [dict get $args cksum] Set cksum to be empty, any tag such as or remove the key and try again." + } + } + + + set ckopts [cksum_filter_opts {*}$args] + set ckinfo [cksum_path $targetpath {*}$ckopts] + + set keyvals $args + dict set keyvals cksum [dict get $ckinfo cksum] + dict set keyvals cksum_all_opts [dict get $ckinfo opts] + if {[dict exists $ckinfo error]} { + dict set keyvals cksum_error [dict get $ckinfo error] + } + + #set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop + #storedpath is relative if possible + return [dict create $storedpath $keyvals] + } + + #calculate the runtime checksum and vfs checksums + proc get_all_vfs_build_cksums {path} { + set buildfolder [get_build_workdir $path] + set cksum_base_folder [file dirname $buildfolder] ;#this is the /src folder - a reasonable base for our vfs cksums + set dict_cksums [dict create] + + set buildrelpath [punk::repo::path_strip_alreadynormalized_prefixdepth $buildfolder $cksum_base_folder] + set vfs_tail_list [glob -nocomplain -dir $cksum_base_folder -type d -tails *.vfs] + + foreach vfstail $vfs_tail_list { + set vname [file rootname $vfstail] + dict set dict_cksums $vfstail [list cksum ""] + dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] + } + + set fullpath_buildruntime $buildfolder/buildruntime.exe + + set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] + set ck [dict get $ckinfo_buildruntime cksum] + + + set relpath [file join $buildrelpath "buildruntime.exe"] + dict set dict_cksums $relpath [list cksum $ck] + + set dict_cksums [fill_relativecksums_from_base_and_relativepathdict $cksum_base_folder $dict_cksums] + + return $dict_cksums + } + + proc get_vfs_build_cksums_stored {vfsfolder} { + set vfscontainer [file dirname $vfsfolder] + set buildfolder $vfscontainer/_build + set vfs [file tail $vfsfolder] + set vname [file rootname $vfs] + set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] + set ckfile $buildfolder/$vname.cksums + if {[file exists $ckfile]} { + set data [punk::mix::util::fcat -translation binary $ckfile] + foreach ln [split $data \n] { + if {[string trim $ln] eq ""} {continue} + lassign $ln path cksum + dict set dict_vfs $path $cksum + } + } + return $dict_vfs + } + proc get_all_build_cksums_stored {path} { + set buildfolder [get_build_workdir $path] + + set vfscontainer [file dirname $buildfolder] + set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] + set dict_cksums [dict create] + foreach vfs $vfslist { + set vname [file rootname $vfs] + set dict_vfs [get_vfs_build_cksums_stored $vfscontainer/$vfs] + + dict set dict_cksums $vname $dict_vfs + } + return $dict_cksums + } + + proc store_vfs_build_cksums {vfsfolder} { + if {![file isdirectory $vfsfolder]} { + error "Unable to find supplied vfsfolder: $vfsfolder" + } + set vfscontainer [file dirname $vfsfolder] + set buildfolder $vfscontainer/_build + set dict_vfs [get_vfs_build_cksums $vfsfolder] + set data "" + dict for {path cksum} $dict_vfs { + append data "$path $cksum" \n + } + set fd [open $buildfolder/$vname.cksums w] + chan configure $fd -translation binary + puts $fd $data + close $fd + return $dict_vfs + } + + + + } +} diff --git a/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm index 1ca4cc14..62e366c1 100644 --- a/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm @@ -73,7 +73,7 @@ namespace eval punk::mix::commandset::layout { set glob * } set layouts [list] - #set tplfolderdict [punk::cap::templates::folders] + #set tplfolderdict [punk::cap::call_handler punk.templates folders] set tplfolderdict [punk::mix::base::lib::get_template_basefolders] dict for {tdir folderinfo} $tplfolderdict { set layout_base $tdir/layouts diff --git a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index d7150abc..06cddf45 100644 --- a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -305,7 +305,7 @@ namespace eval punk::mix::commandset::project { #todo - tag substitutions in src/doc tree - cd $projectdir + ::cd $projectdir if {[file exists $projectdir/src/modules]} { foreach m $opt_modules { @@ -323,7 +323,7 @@ namespace eval punk::mix::commandset::project { #generate www/man/md output in 'embedded' folder which should be checked into repo for online documentation if {[file exists $projectdir/src]} { - cd $projectdir/src + ::cd $projectdir/src #---------- set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] $installer set_source_target $projectdir/src/doc $projectdir/src/embedded @@ -357,7 +357,7 @@ namespace eval punk::mix::commandset::project { $installer destroy } - cd $projectdir + ::cd $projectdir if {![punk::repo::is_fossil_root $projectdir]} { set first_fossil 1 @@ -742,7 +742,7 @@ namespace eval punk::mix::commandset::project { set workingdir [lindex $workdirs 0] puts stdout "1 result. Changing dir to $workingdir" if {[file exists $workingdir]} { - cd $workingdir + ::cd $workingdir return $workingdir } else { puts stderr "path $workingdir doesn't appear to exist" @@ -753,7 +753,7 @@ namespace eval punk::mix::commandset::project { if {[string trim $answer] in $col_rowids} { set index [expr {$answer - 1}] set workingdir [lindex $workdirs $index] - cd $workingdir + ::cd $workingdir puts stdout [pmix stat] return $workingdir } diff --git a/src/bootsupport/modules/punk/mix/templates-0.1.0.tm b/src/bootsupport/modules/punk/mix/templates-0.1.0.tm index d4847541..8d525177 100644 --- a/src/bootsupport/modules/punk/mix/templates-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/templates-0.1.0.tm @@ -23,10 +23,43 @@ package require punk::cap # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::mix::templates { + variable pkg punk::mix::templates + variable cap_provider + punk::cap::register_package punk::mix::templates [list\ - {templates {relpath ../templates}}\ + {punk.templates {relpath ../templates}}\ ] - + namespace eval capsystem { + if {[info commands capprovider.registration] eq ""} { + punk::cap::interface_capprovider.registration create capprovider.registration + oo::objdefine capprovider.registration { + method get_declarations {} { + set decls [list] + lappend decls punk.templates {relpath ../templates} + lappend decls punk.templates {relpath ../templates2} + return $decls + } + } + } + } + + if {[info commands provider] eq ""} { + punk::cap::interface_capprovider.provider create provider + oo::objdefine provider { + method register {{capabilityname_glob *}} { + #puts registering punk::mix::templates $capabilityname + next + } + method capabilities {} { + next + } + } + } + + # -- --- + #provider api + # -- --- + #none - declarations only } diff --git a/src/bootsupport/modules/punk/overlay-0.1.tm b/src/bootsupport/modules/punk/overlay-0.1.tm index 9ee458bf..23e69344 100644 --- a/src/bootsupport/modules/punk/overlay-0.1.tm +++ b/src/bootsupport/modules/punk/overlay-0.1.tm @@ -1,158 +1,158 @@ - - -package require punk::mix::util - -namespace eval ::punk::overlay { - #based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend - # extend an ensemble-like routine with the routines in some namespace - # - # e.g custom_from_base ::punk::mix::cli ::punk::mix::base - # - proc custom_from_base {routine base} { - if {![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 - ] - ] - - punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util - #namespace eval ${routine}::util { - #namespace import ::punk::mix::util::* - #} - punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib - #namespace eval ${routine}::lib [string map [list $base] { - # namespace import ::lib::* - #}] - - namespace eval ${routine}::lib [string map [list $base $routine] { - if {[namespace exists ::lib]} { - set current_paths [namespace path] - if {"" ni $current_paths} { - lappend current_paths - } - namespace path $current_paths - } - }] - - 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 - } - #load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix - #Note: commandset may be imported by different CLIs with different bases *at the same time* - #so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) - #we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. - #commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they - #want the convenience of using lib:xxx with commands coming from those packages. - #This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. - #The basic principle is that the commandset is loaded into the caller(s) with a prefix - #- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) - proc import_commandset {prefix separator cmdnamespace} { - set bad_seps [list "::"] - if {$separator in $bad_seps} { - error "import_commandset invalid separator '$separator'" - } - #namespace may or may not be a package - # allow with or without leading :: - if {[string range $cmdnamespace 0 1] eq "::"} { - set cmdpackage [string range $cmdnamespace 2 end] - } else { - set cmdpackage $cmdnamespace - set cmdnamespace ::$cmdnamespace - } - - if {![namespace exists $cmdnamespace]} { - #only do package require if the namespace not already present - catch {package require $cmdpackage} pkg_load_info - #recheck - if {![namespace exists $cmdnamespace]} { - set prov [package provide $cmdpackage] - if {[string length $prov]} { - set provinfo "(package $cmdpackage is present with version $prov)" - } else { - set provinfo "(package $cmdpackage not present)" - } - error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" - } - } - - punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util - - #let child namespace 'lib' resolve parent namespace and thus util::xxx - namespace eval ${cmdnamespace}::lib [string map [list $cmdnamespace] { - set nspaths [namespace path] - if {"" ni $nspaths} { - lappend nspaths - } - namespace path $nspaths - }] - - set imported_commands [list] - set nscaller [uplevel 1 [list namespace current]] - if {[catch { - namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] - foreach cmd [info commands ${nscaller}::temp_import::*] { - set cmdtail [namespace tail $cmd] - if {$cmdtail eq "_default"} { - set import_as ${nscaller}::${prefix} - } else { - set import_as ${nscaller}::${prefix}${separator}${cmdtail} - } - rename $cmd $import_as - lappend imported_commands $import_as - } - } errM]} { - puts stderr "Error loading commandset $prefix $separator $cmdnamespace" - puts stderr "err: $errM" - } - return $imported_commands - } -} - - -package provide punk::overlay [namespace eval punk::overlay { - variable version - set version 0.1 -}] + + +package require punk::mix::util + +namespace eval ::punk::overlay { + #based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend + # extend an ensemble-like routine with the routines in some namespace + # + # e.g custom_from_base ::punk::mix::cli ::punk::mix::base + # + proc custom_from_base {routine base} { + if {![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 + ] + ] + + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util + #namespace eval ${routine}::util { + #namespace import ::punk::mix::util::* + #} + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib + #namespace eval ${routine}::lib [string map [list $base] { + # namespace import ::lib::* + #}] + + namespace eval ${routine}::lib [string map [list $base $routine] { + if {[namespace exists ::lib]} { + set current_paths [namespace path] + if {"" ni $current_paths} { + lappend current_paths + } + namespace path $current_paths + } + }] + + 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 + } + #load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix + #Note: commandset may be imported by different CLIs with different bases *at the same time* + #so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) + #we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. + #commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they + #want the convenience of using lib:xxx with commands coming from those packages. + #This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. + #The basic principle is that the commandset is loaded into the caller(s) with a prefix + #- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) + proc import_commandset {prefix separator cmdnamespace} { + set bad_seps [list "::"] + if {$separator in $bad_seps} { + error "import_commandset invalid separator '$separator'" + } + #namespace may or may not be a package + # allow with or without leading :: + if {[string range $cmdnamespace 0 1] eq "::"} { + set cmdpackage [string range $cmdnamespace 2 end] + } else { + set cmdpackage $cmdnamespace + set cmdnamespace ::$cmdnamespace + } + + if {![namespace exists $cmdnamespace]} { + #only do package require if the namespace not already present + catch {package require $cmdpackage} pkg_load_info + #recheck + if {![namespace exists $cmdnamespace]} { + set prov [package provide $cmdpackage] + if {[string length $prov]} { + set provinfo "(package $cmdpackage is present with version $prov)" + } else { + set provinfo "(package $cmdpackage not present)" + } + error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" + } + } + + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util + + #let child namespace 'lib' resolve parent namespace and thus util::xxx + namespace eval ${cmdnamespace}::lib [string map [list $cmdnamespace] { + set nspaths [namespace path] + if {"" ni $nspaths} { + lappend nspaths + } + namespace path $nspaths + }] + + set imported_commands [list] + set nscaller [uplevel 1 [list namespace current]] + if {[catch { + namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] + foreach cmd [info commands ${nscaller}::temp_import::*] { + set cmdtail [namespace tail $cmd] + if {$cmdtail eq "_default"} { + set import_as ${nscaller}::${prefix} + } else { + set import_as ${nscaller}::${prefix}${separator}${cmdtail} + } + rename $cmd $import_as + lappend imported_commands $import_as + } + } errM]} { + puts stderr "Error loading commandset $prefix $separator $cmdnamespace" + puts stderr "err: $errM" + } + return $imported_commands + } +} + + +package provide punk::overlay [namespace eval punk::overlay { + variable version + set version 0.1 +}] diff --git a/src/make.tcl b/src/make.tcl index e942ebe7..ce8124f9 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -259,84 +259,110 @@ if {$::punkmake::command eq "bootsupport"} { proc bootsupport_localupdate {projectroot} { set bootsupport_modules [list] + set bootsupport_module_folders [list] set bootsupport_config $projectroot/src/bootsupport/include_modules.config ;# if {[file exists $bootsupport_config]} { + set targetroot $projectroot/src/bootsupport/modules source $bootsupport_config ;#populate $bootsupport_modules with project-specific list if {![llength $bootsupport_modules]} { puts stderr "No local bootsupport modules configured for updating" - return - } - set targetroot $projectroot/src/bootsupport/modules - - if {[catch { - #---------- - set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] - $boot_installer set_source_target $projectroot $projectroot/src/bootsupport - set boot_event [$boot_installer start_event {-make_step bootsupport}] - #---------- - } errM]} { - puts stderr "Unable to use punkcheck for bootsupport error: $errM" - set boot_event "" - } + } else { - foreach {relpath module} $bootsupport_modules { - set module [string trim $module :] - set module_subpath [string map [list :: /] [namespace qualifiers $module]] - set srclocation [file join $projectroot $relpath $module_subpath] - #puts stdout "$relpath $module $module_subpath $srclocation" - set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] - #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 - if {![llength $pkgmatches]} { - puts stderr "Missing source for bootsupport module $module - not found in $srclocation" - continue - } - set latestfile [lindex $pkgmatches 0] - set latestver [lindex [split [file rootname $latestfile] -] 1] - foreach m $pkgmatches { - lassign [split [file rootname $m] -] _pkg ver - #puts "comparing $ver vs $latestver" - if {[package vcompare $ver $latestver] == 1} { - set latestver $ver - set latestfile $m - } - } - set srcfile [file join $srclocation $latestfile] - set tgtfile [file join $targetroot $module_subpath $latestfile] - if {$boot_event ne ""} { + if {[catch { #---------- - $boot_event targetset_init INSTALL $tgtfile - $boot_event targetset_addsource $srcfile + set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] + $boot_installer set_source_target $projectroot $projectroot/src/bootsupport + set boot_event [$boot_installer start_event {-make_step bootsupport}] #---------- - if {\ - [llength [dict get [$boot_event targetset_source_changes] changed]]\ - || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ - } { - file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists - $boot_event targetset_started - # -- --- --- --- --- --- - puts "BOOTSUPPORT update: $srcfile -> $tgtfile" - if {[catch { - file copy -force $srcfile $tgtfile - } errM]} { - $boot_event targetset_end FAILED + } errM]} { + puts stderr "Unable to use punkcheck for bootsupport error: $errM" + set boot_event "" + } + + foreach {relpath module} $bootsupport_modules { + set module [string trim $module :] + set module_subpath [string map [list :: /] [namespace qualifiers $module]] + set srclocation [file join $projectroot $relpath $module_subpath] + #puts stdout "$relpath $module $module_subpath $srclocation" + set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] + #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 + if {![llength $pkgmatches]} { + puts stderr "Missing source for bootsupport module $module - not found in $srclocation" + continue + } + set latestfile [lindex $pkgmatches 0] + set latestver [lindex [split [file rootname $latestfile] -] 1] + foreach m $pkgmatches { + lassign [split [file rootname $m] -] _pkg ver + #puts "comparing $ver vs $latestver" + if {[package vcompare $ver $latestver] == 1} { + set latestver $ver + set latestfile $m + } + } + set srcfile [file join $srclocation $latestfile] + set tgtfile [file join $targetroot $module_subpath $latestfile] + if {$boot_event ne ""} { + #---------- + $boot_event targetset_init INSTALL $tgtfile + $boot_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$boot_event targetset_source_changes] changed]]\ + || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ + } { + file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists + $boot_event targetset_started + # -- --- --- --- --- --- + puts "BOOTSUPPORT update: $srcfile -> $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $boot_event targetset_end FAILED + } else { + $boot_event targetset_end OK + } + # -- --- --- --- --- --- } else { - $boot_event targetset_end OK + puts -nonewline stderr "." + $boot_event targetset_end SKIPPED } - # -- --- --- --- --- --- + $boot_event end } else { - puts -nonewline stderr "." - $boot_event targetset_end SKIPPED + file copy -force $srcfile $tgtfile } - $boot_event end - } else { - file copy -force $srcfile $tgtfile + } + if {$boot_event ne ""} { + puts \n + $boot_event destroy + $boot_installer destroy } } - if {$boot_event ne ""} { - puts \n - $boot_event destroy - $boot_installer destroy + + foreach folder $bootsupport_module_folders { + #explicitly ignore punk/mix/templates folder even if specified in config. + #punk/mix/templates contains modules including punk/mix/templates itself - the actual templates aren't needed for the bootsupport system, + # as make.tcl shouldn't be building new projects from the one being made. + #review. + #should we be autodetecting such recursive folder structures - (or is the bootsupport copying in need of a rethink?) + if {[string trim $folder /] eq "punk/mix/templates"} { + puts stderr "IGNORING punk/mix/templates - not needed/desirable in bootsupport" + continue + } + set src [file join $projectroot/modules $folder] + if {![file isdirectory $src]} { + puts stderr "bootsupport folder not found: $src" + continue + } + set tgt [file join $targetroot $folder] + file mkdir $tgt + + puts stdout "BOOTSUPPORT non_tm_files $src - copying to $tgt (if source file changed)" + set overwrite "installedsourcechanged-targets" + set resultdict [punkcheck::install_non_tm_files $src $tgt -installer make.tcl -overwrite $overwrite -punkcheck_folder $projectroot/src/bootsupport] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] } + } } diff --git a/src/mixtemplates/layouts/basic/src/bootsupport/modules/oolib-0.1.tm b/src/mixtemplates/layouts/basic/src/bootsupport/modules/oolib-0.1.tm index 9cf1ca07..3756fceb 100644 --- a/src/mixtemplates/layouts/basic/src/bootsupport/modules/oolib-0.1.tm +++ b/src/mixtemplates/layouts/basic/src/bootsupport/modules/oolib-0.1.tm @@ -1,195 +1,195 @@ -#JMN - api should be kept in sync with package patternlib where possible -# -package provide oolib [namespace eval oolib { - variable version - set version 0.1 -}] - -namespace eval oolib { - oo::class create collection { - variable o_data ;#dict - variable o_alias - constructor {} { - set o_data [dict create] - } - method info {} { - return [dict info $o_data] - } - method count {} { - return [dict size $o_data] - } - method isEmpty {} { - expr {[dict size $o_data] == 0} - } - method names {{globOrIdx {}}} { - if {[llength $globOrIdx]} { - if {[string is integer -strict $globOrIdx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $idx} result]} { - error "[self object] no such index : '$idx'" - } else { - return $result - } - } else { - #glob - return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] - } - } else { - return [dict keys $o_data] - } - } - #like names but without globbing - method keys {} { - dict keys $o_data - } - method key {{posn 0}} { - if {$posn < 0} { - set posn "end-[expr {abs($posn + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $posn} result]} { - error "[self object] no such index : '$posn'" - } else { - return $result - } - } - method hasKey {key} { - dict exists $o_data $key - } - method get {} { - return $o_data - } - method items {} { - return [dict values $o_data] - } - method item {key} { - if {[string is integer -strict $key]} { - if {$key > 0} { - set valposn [expr {(2*$key) +1}] - return [lindex $o_data $valposn] - } else { - set key "end-[expr {abs($key + 1)}]" - return [lindex [dict keys $o_data] $key] - } - } - if {[dict exists $o_data $key]} { - return [dict get $o_data $key] - } - } - #inverse lookup - method itemKeys {value} { - set value_indices [lsearch -all [dict values $o_data] $value] - set keylist [list] - foreach i $value_indices { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - method search {value args} { - set matches [lsearch {*}$args [dict values $o_data] $value] - if {"-inline" in $args} { - return $matches - } else { - set keylist [list] - foreach i $matches { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - } - #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? - method alias {newAlias existingKeyOrAlias} { - if {[string is integer -strict $newAlias]} { - error "[self object] collection key alias cannot be integer" - } - if {[string length $existingKeyOrAlias]} { - set o_alias($newAlias) $existingKeyOrAlias - } else { - unset o_alias($newAlias) - } - } - method aliases {{key ""}} { - if {[string length $key]} { - set result [list] - foreach {n v} [array get o_alias] { - if {$v eq $key} { - lappend result $n $v - } - } - return $result - } else { - return [array get o_alias] - } - } - #if the supplied index is an alias, return the underlying key; else return the index supplied. - method realKey {idx} { - if {[catch {set o_alias($idx)} key]} { - return $idx - } else { - return $key - } - } - method add {value key} { - if {[string is integer -strict $key]} { - error "[self object] collection key must not be an integer. Use another structure if integer keys required" - } - if {[dict exists $o_data $key]} { - error "[self object] col_processors object error: key '$key' already exists in collection" - } - dict set o_data $key $value - return [expr {[dict size $o_data] - 1}] ;#return index of item - } - method remove {idx {endRange ""}} { - if {[string length $endRange]} { - error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" - } - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx+1)}]" - } - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - if {$posn < 0} { - error "[self object] no such index: '$idx' in this collection" - } - } - dict unset o_data $key - return - } - method clear {} { - set o_data [dict create] - return - } - method reverse {} { - set dictnew [dict create] - foreach k [lreverse [dict keys $o_data]] { - dict set dictnew $k [dict get $o_data $k] - } - set o_data $dictnew - return - } - #review - cmd as list vs cmd as script? - method map {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list {*}$cmd $v]] - } - return $seed - } - method objectmap {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list $v {*}$cmd]] - } - return $seed - } - } - -} - +#JMN - api should be kept in sync with package patternlib where possible +# +package provide oolib [namespace eval oolib { + variable version + set version 0.1 +}] + +namespace eval oolib { + oo::class create collection { + variable o_data ;#dict + variable o_alias + constructor {} { + set o_data [dict create] + } + method info {} { + return [dict info $o_data] + } + method count {} { + return [dict size $o_data] + } + method isEmpty {} { + expr {[dict size $o_data] == 0} + } + method names {{globOrIdx {}}} { + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "[self object] no such index : '$idx'" + } else { + return $result + } + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } + } + #like names but without globbing + method keys {} { + dict keys $o_data + } + method key {{posn 0}} { + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "[self object] no such index : '$posn'" + } else { + return $result + } + } + method hasKey {key} { + dict exists $o_data $key + } + method get {} { + return $o_data + } + method items {} { + return [dict values $o_data] + } + method item {key} { + if {[string is integer -strict $key]} { + if {$key > 0} { + set valposn [expr {(2*$key) +1}] + return [lindex $o_data $valposn] + } else { + set key "end-[expr {abs($key + 1)}]" + return [lindex [dict keys $o_data] $key] + } + } + if {[dict exists $o_data $key]} { + return [dict get $o_data $key] + } + } + #inverse lookup + method itemKeys {value} { + set value_indices [lsearch -all [dict values $o_data] $value] + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + method search {value args} { + set matches [lsearch {*}$args [dict values $o_data] $value] + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + } + #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? + method alias {newAlias existingKeyOrAlias} { + if {[string is integer -strict $newAlias]} { + error "[self object] collection key alias cannot be integer" + } + if {[string length $existingKeyOrAlias]} { + set o_alias($newAlias) $existingKeyOrAlias + } else { + unset o_alias($newAlias) + } + } + method aliases {{key ""}} { + if {[string length $key]} { + set result [list] + foreach {n v} [array get o_alias] { + if {$v eq $key} { + lappend result $n $v + } + } + return $result + } else { + return [array get o_alias] + } + } + #if the supplied index is an alias, return the underlying key; else return the index supplied. + method realKey {idx} { + if {[catch {set o_alias($idx)} key]} { + return $idx + } else { + return $key + } + } + method add {value key} { + if {[string is integer -strict $key]} { + error "[self object] collection key must not be an integer. Use another structure if integer keys required" + } + if {[dict exists $o_data $key]} { + error "[self object] col_processors object error: key '$key' already exists in collection" + } + dict set o_data $key $value + return [expr {[dict size $o_data] - 1}] ;#return index of item + } + method remove {idx {endRange ""}} { + if {[string length $endRange]} { + error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" + } + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx+1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + error "[self object] no such index: '$idx' in this collection" + } + } + dict unset o_data $key + return + } + method clear {} { + set o_data [dict create] + return + } + method reverse {} { + set dictnew [dict create] + foreach k [lreverse [dict keys $o_data]] { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + return + } + #review - cmd as list vs cmd as script? + method map {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list {*}$cmd $v]] + } + return $seed + } + method objectmap {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list $v {*}$cmd]] + } + return $seed + } + } + +} + diff --git a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap-0.1.0.tm b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap-0.1.0.tm index 6749035a..34bed4c0 100644 --- a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap-0.1.0.tm +++ b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap-0.1.0.tm @@ -19,15 +19,171 @@ ## Requirements ##e.g package require frobz - +#concepts: +# A capability may be something like providing a folder of files, or just a data dictionary, and/or an API +# +# capability handler - a package/namespace which may provide validation and standardised ways of looking up provider data +# registered (or not) using register_capabilityname +# capability provider - a package which registers as providing one or more capablities. +# registered using register_package +# the capabilitylist is a list of 2-element lists where the first element is the capabilityname and the second element is a (possibly empty) dict of data relevant to that capability +# A capabilityname may appear multiple times. ie a package may register that it provides the capability with multiple datasets. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::cap { - variable pkgcap [dict create] + variable pkgcapsdeclared [dict create] + variable pkgcapsaccepted [dict create] variable caps [dict create] + if {[info commands [namespace current]::interface_caphandler.registry] eq ""} { + oo::class create [namespace current]::interface_caphandler.registry { + method pkg_register {pkg capname capdict fullcapabilitylist} { + #handler may override and return 0 (indicating don't register)e.g if pkg capdict data wasn't valid + #overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. + return 1 ;#default to permit + } + method pkg_unregister {pkg} { + return ;#unregistration return is ignored - review + } + } + + oo::class create [namespace current]::interface_capprovider.registration { + method get_declarations {} { + error "interface_capprovider.registration not implemented by provider" + } + } + oo::class create [namespace current]::interface_capprovider.provider { + method register {{capabilityname_glob *}} { + + } + method capabilities {} { + + } + } + } + #Not all capabilities have to be registered. + #A package registering as a provider using register_package can include capabilitynames in it's capabilitylist which have no associated capnamespace (handler). + #such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. + #we allow registering a capability with an empty handler (capnamespace) - but this means another handler could be registered later. + proc register_capabilityname {capname capnamespace} { + variable caps + variable pkgcapsdeclared + variable pkgcapsaccepted + if {$capnamespace ne ""} { + #normalize with leading :: in case caller passed in package name rather than fully qualified namespace + if {![string match ::* $capnamespace]} { + set capnamespace ::$capnamespace + } + } + #allow register of existing capname iff there is no current handler + #as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package + #we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers + if {[set hdlr [get_handler $capname]] ne ""} { + error "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" + } + #assert: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries. + dict set caps $capname handler $capnamespace + if {![dict exists $caps $capname providers]} { + dict set caps $capname providers [list] + } + if {[llength [set providers [dict get $caps $capname providers]]]} { + #some provider(s) were in place before the handler was registered + if {[set capreg [get_caphandler_registry $capname]] ne ""} { + foreach pkg $providers { + set fullcapabilitylist [dict get $pkgcapsdeclared $pkg] + foreach capspec $fullcapabilitylist { + lassign $capspec cn capdict + if {$cn ne $capname} { + continue + } + set do_register [$capreg pkg_register $pkg $capdict $fullcapabilitylist] + set list_accepted [dict get $pkgcapsaccepted $pkg] + if {$do_register} { + if {$capspec ni $list_accepted} { + dict lappend pkgcapsaccepted $pkg $capspec + } + } else { + set posn [lsearch $list_accepted $capspec] + if {$posn >=0} { + set list_accepted [lreplace $list_accepted $posn $posn] + dict set pkgcapsaccepted $pkg $list_accepted + } + } + } + #check if any accepted for this cap and remove from caps as necessary + set count 0 + foreach accepted_capspec [dict get $pkgcapsaccepted $pkg] { + if {[lindex $accepted_capspec 0] eq $capname} { + incr count + } + } + if {$count == 0} { + set pkgposn [lsearch $providers $pkg] + if {$pkgposn >= 0} { + set updated_providers [lreplace $providers $posn $posn] + dict set caps $capname providers $updated_providers + } + } + } + + } + + } + } + proc exists {capname} { + variable caps + return [dict exists $caps $capname] + } + proc has_handler {capname} { + variable caps + return [expr {[dict exists $caps $capname handler] && [dict get $caps $capname handler] ne ""}] + } + proc get_handler {capname} { + variable caps + if {[dict exists $caps $capname]} { + return [dict get $caps $capname handler] + } + return "" + } + + #dispatch + #proc call_handler {capname args} { + # if {[set handler [get_handler $capname]] eq ""} { + # error "punk::cap::call_handler $capname $args - no handler registered for capability $capname" + # } + # ${handler}::[lindex $args 0] {*}[lrange $args 1 end] + #} + proc call_handler {capname args} { + if {[set handler [get_handler $capname]] eq ""} { + error "punk::cap::call_handler $capname $args - no handler registered for capability $capname" + } + set obj ${handler}::$capname + $obj [lindex $args 0] {*}[lrange $args 1 end] + } + proc get_caphandler_registry {capname} { + set ns [get_handler $capname]::capsystem + if {[namespace exists ${ns}]} { + if {[info command ${ns}::caphandler.registry] ne ""} { + if {[info object isa object ${ns}::caphandler.registry]} { + return ${ns}::caphandler.registry + } + } + } + return "" + } + proc get_providers {capname} { + variable caps + if {[dict exists $caps $capname]} { + return [dict get $caps $capname providers] + } + return [list] + } + + #register package with arbitrary capnames from capabilitylist + #The registered pkg is a module that provides some service to that capname. Possibly just data members, that the capability will use. proc register_package {pkg capabilitylist} { - variable pkgcap + variable pkgcapsdeclared + variable pkgcapsaccepted variable caps if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] @@ -35,165 +191,209 @@ namespace eval punk::cap { #for each capability # - ensure 1st element is a single word # - ensure that if 2nd element (capdict) is present - it is dict shaped - foreach c $capabilitylist { - lassign $c capname capdict + foreach capspec $capabilitylist { + lassign $capspec capname capdict if {[llength $capname] !=1} { - error "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$c'" + error "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$capspec'" } if {[expr {[llength $capdict] %2 != 0}]} { - error "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$c'" + error "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$capspec'" } if {[dict exists $caps $capname]} { - set cap_pkgs [dict get $caps $capname] + set cap_pkgs [dict get $caps $capname providers] } else { + dict set caps $capname [dict create handler "" providers [list]] set cap_pkgs [list] } - if {$pkg ni $cap_pkgs} { - dict lappend caps $capname $pkg + #todo - if there's a caphandler - call it's init/validation callback for the pkg + set do_register 1 ;#default assumption unless vetoed by handler + if {[set capreg [get_caphandler_registry $capname]] ne ""} { + #Note that the interface_caphandler.registry instance must be able to handle multiple calls for same pkg + set do_register [$capreg pkg_register $pkg $capname $capdict $capabilitylist] + } + if {$do_register} { + if {$pkg ni $cap_pkgs} { + lappend cap_pkgs $pkg + dict set caps $capname providers $cap_pkgs + } + dict lappend pkgcapsaccepted $pkg $capspec ;#if pkg is being registered prior to handler-registration - the handler may undo this entry } } - dict set pkgcap $pkg $capabilitylist + #another call to register_pkg with same pkg may have been made (most likely with different capname) so we must append + #dict lappend pkgcapsdeclared $pkg $capabilitylist + if {[dict exists $pkgcapsdeclared $pkg]} { + set caps [dict get $pkgcapsdeclared $pkg] + lappend caps {*}$capabilitylist + dict set pkgcapsdeclared $pkg $caps + } else { + dict set pkgcapsdeclared $pkg $capabilitylist + } } + proc unregister_package {pkg} { + variable pkgcapsdeclared + variable caps + if {[string match ::* $pkg]} { + set pkg [string range $pkg 2 end] + } + if {[dict exists $pkgcapsdeclared $pkg]} { + #remove corresponding entries in caps + set capabilitylist [dict get $pkgcapsdeclared $pkg] + foreach c $capabilitylist { + set do_unregister 1 + lassign $c capname _capdict + set cap_info [dict get $caps $capname] + set pkglist [dict get $cap_info providers] + set posn [lsearch $pkglist $pkg] + if {$posn >= 0} { + if {[set capreg [get_caphandler_registry $capname]] ne ""} { + #review + # it seems not useful to allow the callback to block this unregister action + #the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter + #vetoing unregister would make this more complex for no particular advantage + #if per capability deregistration required this should probably be a separate thing (e.g disable_capability?) + $capreg pkg_unregister $pkg + } + set pkglist [lreplace $pkglist $posn $posn] + dict set caps $capname providers $pkglist + } + } + #delete the main registration record + dict unset pkgcapsdeclared $pkg + } + } + + #review promote/demote doesn't always make a lot of sense .. should possibly be per cap for multicap pkgs + #The idea is to provide a crude way to preference/depreference packages independently of order the packages were loaded + #e.g a caller or cap-handler can ascribe some meaning to the order of the 'providers' key returned from punk::cap::capabilities + #The order of providers will be the order the packages were loaded & registered + #the naming: "promote vs demote" operates on a latest-package-in-list has higher preference assumption (matching last pkg loaded) + #Each capability handler could implement specific preferencing methods if finer control needed. + #In some cases the preference/loading order may be inapplicable/irrelevant to a particular capability anyway. + #As this is just a basic mechanism, which can't support independent per-cap preferencing for multi-cap packages - + # it only allows putting the pkgs to the head or tail of the lists. + #Whether particular caps or users of caps do anything with this ordering is dependent on the cap-handler and/or calling code. proc promote_package {pkg} { - variable pkgcap + variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] } - if {![dict exists $pkgcap $pkg]} { + if {![dict exists $pkgcapsdeclared $pkg]} { error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" } - if {[dict size $pkgcap] > 1} { - set pkginfo [dict get $pkgcap $pkg] + if {[dict size $pkgcapsdeclared] > 1} { + set pkginfo [dict get $pkgcapsdeclared $pkg] #remove and re-add at end of dict - dict unset pkgcap $pkg - dict set pkgcap $pkg $pkginfo - foreach {cap cap_pkgs} $caps { + dict unset pkgcapsdeclared $pkg + dict set pkgcapsdeclared $pkg $pkginfo + dict for {cap cap_info} $caps { + set cap_pkgs [dict get $cap_info providers] if {$pkg in $cap_pkgs} { set posn [lsearch $cap_pkgs $pkg] if {$posn >=0} { #rewrite package list with pkg at tail of list for this capability set cap_pkgs [lreplace $cap_pkgs $posn $posn] lappend cap_pkgs $pkg - dict set caps $cap $cap_pkgs + dict set caps $cap providers $cap_pkgs } } } } } proc demote_package {pkg} { - variable pkgcap + variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] } - if {![dict exists $pkgcap $pkg]} { + if {![dict exists $pkgcapsdeclared $pkg]} { error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" } - if {[dict size $pkgcap] > 1} { - set pkginfo [dict get $pkgcap $pkg] + if {[dict size $pkgcapsdeclared] > 1} { + set pkginfo [dict get $pkgcapsdeclared $pkg] #remove and re-add at start of dict - dict unset pkgcap $pkg - dict set pkgcap $pkg $pkginfo - set pkgcap [dict merge [dict create $pkg $pkginfo] $pkgcap] - foreach {cap cap_pkgs} $caps { + dict unset pkgcapsdeclared $pkg + dict set pkgcapsdeclared $pkg $pkginfo + set pkgcapsdeclared [dict merge [dict create $pkg $pkginfo] $pkgcapsdeclared] + dict for {cap cap_info} $caps { + set cap_pkgs [dict get $cap_info providers] if {$pkg in $cap_pkgs} { set posn [lsearch $cap_pkgs $pkg] if {$posn >=0} { #rewrite package list with pkg at head of list for this capability set cap_pkgs [lreplace $cap_pkgs $posn $posn] set cap_pkgs [list $pkg {*}$cap_pkgs] - dict set caps $cap $cap_pkgs + dict set caps $cap providers $cap_pkgs } } } } } - proc unregister_package {pkg} { - variable pkgcap - variable caps + proc pkgcap {pkg} { + variable pkgcapsdeclared + variable pkgcapsaccepted if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] } - if {[dict exists $pkgcap $pkg]} { - #remove corresponding entries in caps - set capabilitylist [dict get $pkgcap $pkg] - foreach c $capabilitylist { - lassign $c capname _capdict - set pkglist [dict get $caps $capname] - set posn [lsearch $pkglist $pkg] - if {$posn >= 0} { - set pkglist [lreplace $pkglist $posn $posn] - dict set caps $capname $pkglist - } + if {[dict exists $pkgcapsdeclared $pkg]} { + set accepted "" + if {[dict exists $pkgcapsaccepted $pkg]} { + set accepted [dict get $pkgcapsaccepted $pkg] } - #delete the main registration record - dict unset pkgcap $pkg - } - } - proc registered_package {pkg} { - variable pkgcap - if {[string match ::* $pkg]} { - set pkg [string range $pkg 2 end] - } - if {[dict exists $pkgcap $pkg]} { - return [dict get $pkgcap $pkg] + return [dict create declared [dict get $pkgcapsdeclared $pkg] accepted $accepted] } else { return } } - proc registered_packages {} { - variable pkgcap - return $pkgcap + proc pkgcaps {} { + variable pkgcapsdeclared + variable pkgcapsaccepted + set result [dict create] + foreach {pkg capsdeclared} $pkgcapsdeclared { + set accepted "" + if {[dict exists $pkgcapsaccepted $pkg]} { + set accepted [dict get $pkgcapsaccepted $pkg] + } + dict set result $pkg declared $capsdeclared + dict set result $pkg accepted $accepted + } + return $result } + proc capability {capname} { + variable caps + if {[dict exists $caps $capname]} { + return [dict get $caps $capname] + } + return "" + } proc capabilities {{glob *}} { variable caps - set keys [lsort [dict keys $caps $glob]] + set capnames [lsort [dict keys $caps $glob]] set cap_list [list] - foreach k $keys { - lappend cap_list [list $k [dict get $caps $k]] + foreach capname $capnames { + lappend cap_list [list $capname [dict get $caps $capname]] } return $cap_list } - namespace eval templates { - #return a dict keyed on folder with source pkg as value - proc folders {} { - package require punk::cap - set caplist [punk::cap::capabilities templates] - # e.g {templates {punk::mix::templates ::somepkg}} - set templates_record [lindex $caplist 0] - set pkgs [lindex $templates_record 1] - - set folderdict [dict create] - foreach pkg $pkgs { - set caplist [punk::cap::registered_package $pkg] - set templates_entries [lsearch -all -inline -index 0 $caplist templates] ;#we generally expect only one - but if multiple exist - use them - foreach templates_info $templates_entries { - lassign $templates_info _templates templates_dict - if {[dict exists $templates_dict relpath]} { - set provide_statement [package ifneeded $pkg [package require $pkg]] - set tmfile [lindex $provide_statement end] - #set tmdir [file dirname [lindex $provide_statement end]] - set tpath [file normalize [file join $tmfile [dict get $templates_dict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder - #relpath relative to file is important for tm files that are zip/tar based containers - if {[file isdirectory $tpath]} { - dict set folderdict $tpath [list source $pkg sourcetype package] - } else { - puts stderr "punk::cap::templates::folders WARNING - unable to determine base folder for package '$pkg' which is registered with punk::mix as a provider of 'templates' capability" - } - } else { - puts stderr "punk::cap::templates::folders WARNING - registered pkg 'pkg' has capability 'templates' but no 'relpath' key - unable to use as source of templates" - } - } + proc capabilitynames {{glob *}} { + variable caps + return [lsort [dict keys $caps $glob]] + } + #return only those capnames which have at least one provider + proc capabilitynames_provided {{glob *}} { + variable caps + set keys [lsort [dict keys $caps $glob]] + set cap_list [list] + foreach k $keys { + if {[llength [dict get $caps $k providers]] > 0} { + lappend cap_list $k } - return $folderdict } - - - + return $cap_list } + } diff --git a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm new file mode 100644 index 00000000..8fdce944 --- /dev/null +++ b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm @@ -0,0 +1,52 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -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) 2023 +# +# @@ Meta Begin +# Application punk::cap::handlers::caphandler 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::cap::handlers::caphandler { + + + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::cap::handlers::caphandler [namespace eval punk::cap::handlers::caphandler { + variable pkg punk::cap::handlers::caphandler + variable version + set version 0.1.0 +}] +return \ No newline at end of file diff --git a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/scriptlibs-0.1.0.tm b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/scriptlibs-0.1.0.tm new file mode 100644 index 00000000..8298ec18 --- /dev/null +++ b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/scriptlibs-0.1.0.tm @@ -0,0 +1,52 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -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) 2023 +# +# @@ Meta Begin +# Application punk::cap::handlers::scriptlibs 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::cap::handlers::scriptlibs { + + + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::cap::handlers::scriptlibs [namespace eval punk::cap::handlers::scriptlibs { + variable pkg punk::cap::handlers::scriptlibs + variable version + set version 0.1.0 +}] +return \ No newline at end of file diff --git a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm new file mode 100644 index 00000000..28a25e6f --- /dev/null +++ b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm @@ -0,0 +1,127 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -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) 2023 +# +# @@ Meta Begin +# Application punk::cap::handlers::templates 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#register using: +# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates + +#By convention and for consistency, we don't register here during package loading - but require the calling app to do it. +# (even if it tends to be done immediately after package require anyway) +# registering capability handlers can involve validating existing provider data and is best done explicitly as required. +# It is also possible for a capability handler to be registered to handle more than one capabilityname + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::cap::handlers::templates { + namespace eval capsystem { + #interfaces for punk::cap to call into + if {[info commands caphandler.registry] eq ""} { + punk::cap::interface_caphandler.registry create caphandler.registry + oo::objdefine caphandler.registry { + method pkg_register {pkg capname capdict caplist} { + #caplist may not be complete set - which somewhat reduces its utility here regarding any decisions based on the context of this capname/capdict (review - remove this arg?) + if {![dict exists $capdict relpath]} { + puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing 'relpath' key" + return 0 + } + set provide_statement [package ifneeded $pkg [package require $pkg]] + set tmfile [lindex $provide_statement end] + if {![file exists $tmfile]} { + puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" + return 0 + } + set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder + if {![file isdirectory $tpath]} { + puts stderr "punk::cap::handlers::templates::capsystem pkg_register WARNING - unable to validate relpath location [dict get $capdict relpath] ($tpath) for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" + } + if {$capname ni $::punk::cap::handlers::templates::handled_caps} { + lappend ::punk::cap::handlers::templates::handled_caps $capname + } + if {[info commands punk::cap::handlers::templates::$capname] eq ""} { + punk::cap::handlers::templates::api create ::punk::cap::handlers::templates::$capname $capname + } + set cname [string map [list . _] $capname] + upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders + dict lappend pfolders $pkg $tpath + return 1 + } + method pkg_unregister {pkg} { + upvar ::punk::cap::handlers::templates::handled_caps hcaps + foreach capname $hcaps { + set cname [string map [list . _] $capname] + upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders + dict unset pfolders $pkg + #destroy api objects? + } + } + } + } + } + + variable handled_caps [list] + #variable pkg_folders [dict create] + + # -- --- --- --- --- --- --- + #handler api for clients of this capability - called via punk::cap::call_handler ?args? + # -- --- --- --- --- --- --- + namespace export * + + oo::class create api { + #return a dict keyed on folder with source pkg as value + constructor {capname} { + variable capabilityname + variable cname + set cname [string map [list . _] $capname] + set capabilityname $capname + } + method folders {} { + variable capabilityname + variable cname + upvar punk::cap::handlers::templates::pkg_folders_$cname pkg_folders + package require punk::cap + set capinfo [punk::cap::capability $capabilityname] + # e.g {punk.templates {handler punk::mix::templates providers ::somepkg}} + + #use the order of pkgs as registered with punk::cap - may have been modified with punk::cap::promote_package/demote_package + set pkgs [dict get $capinfo providers] + set folderdict [dict create] + foreach pkg $pkgs { + foreach pfolder [dict get $pkg_folders $pkg] { + dict set folderdict $pfolder [list source $pkg sourcetype package] + } + } + return $folderdict + } + } + + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::cap::handlers::templates [namespace eval punk::cap::handlers::templates { + variable pkg punk::cap::handlers::templates + variable version + set version 0.1.0 +}] +return \ No newline at end of file diff --git a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix-0.2.tm b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix-0.2.tm index 2988b428..d09dfca8 100644 --- a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix-0.2.tm +++ b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix-0.2.tm @@ -1,6 +1,12 @@ package require punk::cap -package require punk::mix::templates ;#registers 'templates' capability with punk::cap + +package require punk::cap::handlers::templates ;#handler for templates cap +punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates + +package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap +#punk::mix::templates::provider register * + package require punk::mix::base package require punk::mix::cli diff --git a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/base-0.1.tm b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/base-0.1.tm index 0f131936..fcfaf56b 100644 --- a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/base-0.1.tm +++ b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/base-0.1.tm @@ -1,904 +1,908 @@ -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] ;#dependency on punk pipeline/patternmatching system - lassign [_split_args $args] _opts opts _args args - if {[dict exists $opts -extension]} { - set extension [dict get $opts -extension] - } else { - set extension "" - } - #--------- - - uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] - } - proc _cli {args} { - #--------- - #extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system - lassign [_split_args $args] _opts opts _args args - if {[dict exists $opts -extension]} { - set extension [dict get $opts -extension] - } else { - set extension "" - } - #--------- - if {![string length $extension]} { - set extension [namespace qualifiers [lindex [info level -1] 0]] - } - #puts stderr "punk::mix::base extension: [string trimleft $extension :]" - if {![string length $extension]} { - #if still no extension - must have been called dirctly as punk::mix::base::_cli - if {![llength $args]} { - set args "help" - } - set extension [namespace current] - } - 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] ;#dependency on punk pipeline/patternmatching system - lassign [_split_args $args] _opts opts _args args - if {[dict exists $opts -extension]} { - set extension [dict get $opts -extension] - } else { - set extension "" - } - #--------- - - 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 "_redirected $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 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] ;#dependency on punk pipeline/patternmatching system - lassign [_split_args $args] _opts opts _args args - if {[dict exists $opts -extension]} { - set extension [dict get $opts -extension] - } else { - set extension "" - } - #--------- - 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 - #' ``` - #' - #' - - - #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> " opts $opts] - } - if {$ftype ni [list file directory]} { - #review - links? - error "cksum_path error file type '$ftype' not supported" - } - - - set opt_cksum_algorithm [dict get $opts -cksum_algorithm] - if {$opt_cksum_algorithm ni [cksum_algorithms]} { - return [list error unsupported_cksum_algorithm cksum "" opts $opts] - } - set opt_cksum_acls [dict get $opts -cksum_acls] - if {$opt_cksum_acls} { - puts stderr "cksum_path is not yet able to cksum ACLs" - return - } - - set opt_cksum_meta [dict get $opts -cksum_meta] - set opt_use_tar [dict get $opts -cksum_usetar] - if {$ftype eq "file"} { - if {$opt_use_tar eq "auto"} { - if {$opt_cksum_meta eq "1"} { - set opt_use_tar 1 - } else { - #prefer no tar if meta not required - faster/simpler - #meta == auto or 0 - set opt_cksum_meta 0 - set opt_use_tar 0 - } - } elseif {$opt_use_tar eq "0"} { - if {$opt_cksum_meta eq "1"} { - puts stderr "cksum_path doesn't yet support a non-tar cksum with metadata for a file" - return [list error unsupported_meta_without_tar cksum "" opts $opts] - } else { - #meta == auto or 0 - set opt_cksum_meta 0 - } - } else { - #tar == 1 - if {$opt_cksum_meta eq "0"} { - puts stderr "cksum_path doesn't yet support a tar cksum without metadata for a file" - return [list error unsupported_tar_without_meta cksum "" opts $opts] - } else { - #meta == auto or 1 - set opt_cksum_meta 1 - } - } - } elseif {$ftype eq "directory"} { - if {$opt_use_tar eq "auto"} { - if {$opt_cksum_meta in [list "auto" "1"]} { - set opt_use_tar 1 - set opt_cksum_meta 1 - } else { - puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto" - return [list error unsupported_directory_cksum_without_meta cksum "" opts $opts] - } - } elseif {$opt_use_tar eq "0"} { - puts stderr "cksum_path doesn't yet support a cksum of a folder structure without tar. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" - return [list error unsupported_directory_cksum_without_tar cksum "" opts $opts] - } else { - #tar 1 - if {$opt_cksum_meta eq "0"} { - puts stderr "cksum_path doesn't yet support a tar checksum of a folder structure without metadat. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" - return [list error unsupported_without_meta cksum "" opts $opts] - } else { - #meta == auto or 1 - set opt_cksum_meta 1 - } - } - } - - dict set opts_actual -cksum_meta $opt_cksum_meta - dict set opts_actual -cksum_usetar $opt_use_tar - - - if {$opt_use_tar} { - package require tar ;#from tcllib - } - - if {$path eq $base} { - #attempting to cksum at root/volume level of a filesystem.. extra work - #This needs fixing for general use.. not necessarily just for project repos - puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" - return [list error unsupported_path opts $opts] - } - - if {$opt_cksum_algorithm eq "sha1"} { - package require sha1 - set cksum_command [list sha1::sha1 -hex -file] - } elseif {$opt_cksum_algorithm in [list "sha2" "sha256"]} { - package require sha256 - set cksum_command [list sha2::sha256 -hex -file] - } elseif {$opt_cksum_algorithm eq "md5"} { - package require md5 - set cksum_command [list md5::md5 -hex -file] - } elseif {$opt_cksum_algorithm eq "cksum"} { - package require cksum ;#tcllib - set cksum_command [list crc::cksum -format 0x%X -file] - } elseif {$opt_cksum_algorithm eq "adler32"} { - set cksum_command [list cksum_adler32_file] - } elseif {$opt_cksum_algorithm in [list "sha3" "sha3-256"]} { - #todo - replace with something that doesn't call another process - #set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] - set cksum_command [list $sha3_implementation 256] - } elseif {$opt_cksum_algorithm in [list "sha3-224" "sha3-384" "sha3-512"]} { - set bits [lindex [split $opt_cksum_algorithm -] 1] - #set cksum_command [list apply {{bits file} {lindex [exec fossil sha3sum -$bits $file] 0}} $bits] - set cksum_command [list $sha3_implementation $bits] - } - - set cksum "" - if {$opt_use_tar != 0} { - set target [file tail $path] - set tmplocation [punk::mix::util::tmpdir] - set archivename $tmplocation/[punk::mix::util::tmpfile].tar - - cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) - - #temp emission to stdout.. todo - repl telemetry channel - puts stdout "cksum_path: creating temporary tar archive at: $archivename .." - tar::create $archivename $target - if {$ftype eq "file"} { - set sizeinfo "(size [file size $target])" - } else { - set sizeinfo "(file type $ftype - size unknown)" - } - puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." - set cksum [{*}$cksum_command $archivename] - #puts stdout "cksum_path: cleaning up.. " - file delete -force $archivename - cd $startdir - - } else { - #todo - if {$ftype eq "file"} { - if {$opt_cksum_meta} { - return [list error unsupported_opts_combo cksum "" opts $opts] - } else { - set cksum [{*}$cksum_command $path] - } - } else { - error "cksum_path unsupported $opts for path type [file type $path]" - } - } - set result [dict create] - dict set result cksum $cksum - dict set result opts $opts_actual - return $result - } - - #dict_path_cksum keyed on path - with value as a dict that must contain cksum key - but can contain other keys - #e.g -cksum_usetar which is one of the keys understood by the punk::mix::base::lib::cksum_path function - or unrelated keys which will also be passed through - #cksum only calculated for keys in dict where cksum is empty - ie return same dict but with empty cksums filled out. - #base can be empty string in which case paths must be absolute - proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { - if {$base eq ""} { - set error_paths [list] - dict for {path pathinfo} $dict_path_cksum { - if {[file pathtype $path] ne "absolute"} { - lappend error_paths $path - } - } - if {[llength $error_paths]} { - puts stderr "get_relativecksums_from_base_and_relativepathdict has empty base - and non-absolute paths in the supplied checksum dict - aborting" - puts stderr "error_paths: $error_paths" - error "fill_relativecksums_from_base_and_relativepathdict error: non-absolute paths when base empty. $error_paths" - } - } else { - if {[file pathtype $base] ne "absolute"} { - error "fill_relativecksums_from_base_and_relativepathdict error: base supplied but was not absolute path. $base" - } - #conversely now we have a base - so we require all paths are relative. - #We will ignore/disallow volume-relative - as these shouldn't be used here either - set error_paths [list] - dict for {path pathinfo} $dict_path_cksum { - if {[file pathtype $path] ne "relative"} { - lappend error_paths $path - } - } - if {[llength $error_paths]} { - puts stderr "fill_relativecksums_from_base_and_relativepathdict has a supplied absolute base path, but some of the paths in the supplied dict are not relative - aborting" - error "fill_relativecksums_from_base_and_relativepathdict error: non-relative paths when base supplied. $error_paths" - } - } - - - dict for {path pathinfo} $dict_path_cksum { - if {![dict exists $pathinfo cksum]} { - dict set pathinfo cksum "" - } else { - if {[dict get $pathinfo cksum] ne "" && ![cksum_is_tag [dict get $pathinfo cksum]]} { - continue ;#already filled with non-tag value - } - } - if {$base ne ""} { - set fullpath [file join $base $path] - } else { - set fullpath $path - } - - set ckopts [cksum_filter_opts {*}$pathinfo] - - if {![file exists $fullpath]} { - dict set dict_path_cksum $path cksum "" - } else { - set ckinfo [cksum_path $fullpath {*}$ckopts] - dict set dict_path_cksum $path cksum [dict get $ckinfo cksum] - dict set dict_path_cksum $path cksum_all_opts [dict get $ckinfo opts] - if {[dict exists $ckinfo error]} { - dict set dict_path_cksum $path cksum_error [dict get $ckinfo error] - } - } - } - - return $dict_path_cksum - } - #whether cksum is e.g - proc cksum_is_tag {cksum} { - expr {[string index $cksum 0] eq "<" && [string index $cksum end] eq ">"} - } - proc cksum_filter_opts {args} { - set ck_opt_names [dict keys [cksum_default_opts]] - set ck_opts [dict create] - dict for {k v} $args { - if {$k in $ck_opt_names} { - dict set ck_opts $k $v - } - } - return $ck_opts - } - - #convenience so caller doesn't have to pre-calculate the relative path from the base - #Note semantic difference from fill_relativecksums_from_base_and_relativepathdict (hence get_ vs fill_) - #Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will ignore valid-looking prefilled cksum values - #base is the presumed location to store the checksum file. The caller should retain (normalize if relative) - proc get_relativecksum_from_base {base specifiedpath args} { - if {$base ne ""} { - #targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it - #we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix - if {[file pathtype $specifiedpath] eq "relative"} { - if {[file pathtype $base] eq "relative"} { - set normbase [file normalize $base] - set normtarg [file normalize [file join $normbase $specifiedpath]] - set targetpath $normtarg - set storedpath [punk::mix::util::path_relative $normbase $normtarg] - } else { - set targetpath [file join $base $specifiedpath] - set storedpath $specifiedpath - } - } else { - #specifed absolute - if {[file pathtype $base] eq "relative"} { - #relative to cwd or to specifiedpath? For consistency it should arguably be cwd but a case could be made that when one path is relative it is in reference to the other - #there is a strong possibility that allowing this combination will cause confusion - better to disallow - error "get_relativecksum_from_base error: disallowed pathtype combination. Base must be empty or absolute when specified path is absolute" - } - #both absolute - compute relative path if they share a common prefix - set commonprefix [punk::mix::util::path_common_prefix $base $specifiedpath] - if {$commonprefix eq ""} { - #absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base - error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" - } - set targetpath $specifiedpath - set storedpath [punk::mix::util::path_relative $base $specifiedpath] - - } - } else { - if {[file type $specifiedpath] eq "relative"} { - #if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage - set targetpath [file normalize $specifiedpath] - set storedpath $targetpath - } else { - set targetpath $specifiedpath - set storedpath $targetpath - } - } - - # - #NOTE: specifiedpath can be a relative path (to cwd) when base is empty - #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc - #possibly also: base: somewhere targetpath: ../elsewhere/etc - # - #todo - write tests - - - if {([llength $args] % 2) != 0} { - error "get_relativecksum_from_base error. args supplied must be in the form of key-value pairs. received '$args' " - } - if {[dict exists $args cksum]} { - if {[dict get $args cksum] ne "" && ![cksum_is_tag [dict get $args cksum]]} { - error "get_relativecksum_from_base called with existing cksum value (and is not a tag or empty-value to be replaced) cksum: [dict get $args cksum] Set cksum to be empty, any tag such as or remove the key and try again." - } - } - - - set ckopts [cksum_filter_opts {*}$args] - set ckinfo [cksum_path $targetpath {*}$ckopts] - - set keyvals $args - dict set keyvals cksum [dict get $ckinfo cksum] - dict set keyvals cksum_all_opts [dict get $ckinfo opts] - if {[dict exists $ckinfo error]} { - dict set keyvals cksum_error [dict get $ckinfo error] - } - - #set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop - #storedpath is relative if possible - return [dict create $storedpath $keyvals] - } - - #calculate the runtime checksum and vfs checksums - proc get_all_vfs_build_cksums {path} { - set buildfolder [get_build_workdir $path] - set cksum_base_folder [file dirname $buildfolder] ;#this is the /src folder - a reasonable base for our vfs cksums - set dict_cksums [dict create] - - set buildrelpath [punk::repo::path_strip_alreadynormalized_prefixdepth $buildfolder $cksum_base_folder] - set vfs_tail_list [glob -nocomplain -dir $cksum_base_folder -type d -tails *.vfs] - - foreach vfstail $vfs_tail_list { - set vname [file rootname $vfstail] - dict set dict_cksums $vfstail [list cksum ""] - dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] - } - - set fullpath_buildruntime $buildfolder/buildruntime.exe - - set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] - set ck [dict get $ckinfo_buildruntime cksum] - - - set relpath [file join $buildrelpath "buildruntime.exe"] - dict set dict_cksums $relpath [list cksum $ck] - - set dict_cksums [fill_relativecksums_from_base_and_relativepathdict $cksum_base_folder $dict_cksums] - - return $dict_cksums - } - - proc get_vfs_build_cksums_stored {vfsfolder} { - set vfscontainer [file dirname $vfsfolder] - set buildfolder $vfscontainer/_build - set vfs [file tail $vfsfolder] - set vname [file rootname $vfs] - set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] - set ckfile $buildfolder/$vname.cksums - if {[file exists $ckfile]} { - set data [punk::mix::util::fcat -translation binary $ckfile] - foreach ln [split $data \n] { - if {[string trim $ln] eq ""} {continue} - lassign $ln path cksum - dict set dict_vfs $path $cksum - } - } - return $dict_vfs - } - proc get_all_build_cksums_stored {path} { - set buildfolder [get_build_workdir $path] - - set vfscontainer [file dirname $buildfolder] - set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] - set dict_cksums [dict create] - foreach vfs $vfslist { - set vname [file rootname $vfs] - set dict_vfs [get_vfs_build_cksums_stored $vfscontainer/$vfs] - - dict set dict_cksums $vname $dict_vfs - } - return $dict_cksums - } - - proc store_vfs_build_cksums {vfsfolder} { - if {![file isdirectory $vfsfolder]} { - error "Unable to find supplied vfsfolder: $vfsfolder" - } - set vfscontainer [file dirname $vfsfolder] - set buildfolder $vfscontainer/_build - set dict_vfs [get_vfs_build_cksums $vfsfolder] - set data "" - dict for {path cksum} $dict_vfs { - append data "$path $cksum" \n - } - set fd [open $buildfolder/$vname.cksums w] - chan configure $fd -translation binary - puts $fd $data - close $fd - return $dict_vfs - } - - - - } -} +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] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + + uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] + } + proc _cli {args} { + #--------- + #extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + if {![string length $extension]} { + set extension [namespace qualifiers [lindex [info level -1] 0]] + } + #puts stderr "punk::mix::base extension: [string trimleft $extension :]" + if {![string length $extension]} { + #if still no extension - must have been called dirctly as punk::mix::base::_cli + if {![llength $args]} { + set args "help" + } + set extension [namespace current] + } + 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] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + + 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 "_redirected $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 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] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + 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 + #' ``` + #' + #' + + + #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> " opts $opts] + } + if {$ftype ni [list file directory]} { + #review - links? + error "cksum_path error file type '$ftype' not supported" + } + + + set opt_cksum_algorithm [dict get $opts -cksum_algorithm] + if {$opt_cksum_algorithm ni [cksum_algorithms]} { + return [list error unsupported_cksum_algorithm cksum "" opts $opts] + } + set opt_cksum_acls [dict get $opts -cksum_acls] + if {$opt_cksum_acls} { + puts stderr "cksum_path is not yet able to cksum ACLs" + return + } + + set opt_cksum_meta [dict get $opts -cksum_meta] + set opt_use_tar [dict get $opts -cksum_usetar] + if {$ftype eq "file"} { + if {$opt_use_tar eq "auto"} { + if {$opt_cksum_meta eq "1"} { + set opt_use_tar 1 + } else { + #prefer no tar if meta not required - faster/simpler + #meta == auto or 0 + set opt_cksum_meta 0 + set opt_use_tar 0 + } + } elseif {$opt_use_tar eq "0"} { + if {$opt_cksum_meta eq "1"} { + puts stderr "cksum_path doesn't yet support a non-tar cksum with metadata for a file" + return [list error unsupported_meta_without_tar cksum "" opts $opts] + } else { + #meta == auto or 0 + set opt_cksum_meta 0 + } + } else { + #tar == 1 + if {$opt_cksum_meta eq "0"} { + puts stderr "cksum_path doesn't yet support a tar cksum without metadata for a file" + return [list error unsupported_tar_without_meta cksum "" opts $opts] + } else { + #meta == auto or 1 + set opt_cksum_meta 1 + } + } + } elseif {$ftype eq "directory"} { + if {$opt_use_tar eq "auto"} { + if {$opt_cksum_meta in [list "auto" "1"]} { + set opt_use_tar 1 + set opt_cksum_meta 1 + } else { + puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto" + return [list error unsupported_directory_cksum_without_meta cksum "" opts $opts] + } + } elseif {$opt_use_tar eq "0"} { + puts stderr "cksum_path doesn't yet support a cksum of a folder structure without tar. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" + return [list error unsupported_directory_cksum_without_tar cksum "" opts $opts] + } else { + #tar 1 + if {$opt_cksum_meta eq "0"} { + puts stderr "cksum_path doesn't yet support a tar checksum of a folder structure without metadat. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" + return [list error unsupported_without_meta cksum "" opts $opts] + } else { + #meta == auto or 1 + set opt_cksum_meta 1 + } + } + } + + dict set opts_actual -cksum_meta $opt_cksum_meta + dict set opts_actual -cksum_usetar $opt_use_tar + + + if {$opt_use_tar} { + package require tar ;#from tcllib + } + + if {$path eq $base} { + #attempting to cksum at root/volume level of a filesystem.. extra work + #This needs fixing for general use.. not necessarily just for project repos + puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" + return [list error unsupported_path opts $opts] + } + + if {$opt_cksum_algorithm eq "sha1"} { + package require sha1 + set cksum_command [list sha1::sha1 -hex -file] + } elseif {$opt_cksum_algorithm in [list "sha2" "sha256"]} { + package require sha256 + set cksum_command [list sha2::sha256 -hex -file] + } elseif {$opt_cksum_algorithm eq "md5"} { + package require md5 + set cksum_command [list md5::md5 -hex -file] + } elseif {$opt_cksum_algorithm eq "cksum"} { + package require cksum ;#tcllib + set cksum_command [list crc::cksum -format 0x%X -file] + } elseif {$opt_cksum_algorithm eq "adler32"} { + set cksum_command [list cksum_adler32_file] + } elseif {$opt_cksum_algorithm in [list "sha3" "sha3-256"]} { + #todo - replace with something that doesn't call another process + #set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] + set cksum_command [list $sha3_implementation 256] + } elseif {$opt_cksum_algorithm in [list "sha3-224" "sha3-384" "sha3-512"]} { + set bits [lindex [split $opt_cksum_algorithm -] 1] + #set cksum_command [list apply {{bits file} {lindex [exec fossil sha3sum -$bits $file] 0}} $bits] + set cksum_command [list $sha3_implementation $bits] + } + + set cksum "" + if {$opt_use_tar != 0} { + set target [file tail $path] + set tmplocation [punk::mix::util::tmpdir] + set archivename $tmplocation/[punk::mix::util::tmpfile].tar + + cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) + + #temp emission to stdout.. todo - repl telemetry channel + puts stdout "cksum_path: creating temporary tar archive at: $archivename .." + tar::create $archivename $target + if {$ftype eq "file"} { + set sizeinfo "(size [file size $target])" + } else { + set sizeinfo "(file type $ftype - size unknown)" + } + puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." + set cksum [{*}$cksum_command $archivename] + #puts stdout "cksum_path: cleaning up.. " + file delete -force $archivename + cd $startdir + + } else { + #todo + if {$ftype eq "file"} { + if {$opt_cksum_meta} { + return [list error unsupported_opts_combo cksum "" opts $opts] + } else { + set cksum [{*}$cksum_command $path] + } + } else { + error "cksum_path unsupported $opts for path type [file type $path]" + } + } + set result [dict create] + dict set result cksum $cksum + dict set result opts $opts_actual + return $result + } + + #dict_path_cksum keyed on path - with value as a dict that must contain cksum key - but can contain other keys + #e.g -cksum_usetar which is one of the keys understood by the punk::mix::base::lib::cksum_path function - or unrelated keys which will also be passed through + #cksum only calculated for keys in dict where cksum is empty - ie return same dict but with empty cksums filled out. + #base can be empty string in which case paths must be absolute + proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { + if {$base eq ""} { + set error_paths [list] + dict for {path pathinfo} $dict_path_cksum { + if {[file pathtype $path] ne "absolute"} { + lappend error_paths $path + } + } + if {[llength $error_paths]} { + puts stderr "get_relativecksums_from_base_and_relativepathdict has empty base - and non-absolute paths in the supplied checksum dict - aborting" + puts stderr "error_paths: $error_paths" + error "fill_relativecksums_from_base_and_relativepathdict error: non-absolute paths when base empty. $error_paths" + } + } else { + if {[file pathtype $base] ne "absolute"} { + error "fill_relativecksums_from_base_and_relativepathdict error: base supplied but was not absolute path. $base" + } + #conversely now we have a base - so we require all paths are relative. + #We will ignore/disallow volume-relative - as these shouldn't be used here either + set error_paths [list] + dict for {path pathinfo} $dict_path_cksum { + if {[file pathtype $path] ne "relative"} { + lappend error_paths $path + } + } + if {[llength $error_paths]} { + puts stderr "fill_relativecksums_from_base_and_relativepathdict has a supplied absolute base path, but some of the paths in the supplied dict are not relative - aborting" + error "fill_relativecksums_from_base_and_relativepathdict error: non-relative paths when base supplied. $error_paths" + } + } + + + dict for {path pathinfo} $dict_path_cksum { + if {![dict exists $pathinfo cksum]} { + dict set pathinfo cksum "" + } else { + if {[dict get $pathinfo cksum] ne "" && ![cksum_is_tag [dict get $pathinfo cksum]]} { + continue ;#already filled with non-tag value + } + } + if {$base ne ""} { + set fullpath [file join $base $path] + } else { + set fullpath $path + } + + set ckopts [cksum_filter_opts {*}$pathinfo] + + if {![file exists $fullpath]} { + dict set dict_path_cksum $path cksum "" + } else { + set ckinfo [cksum_path $fullpath {*}$ckopts] + dict set dict_path_cksum $path cksum [dict get $ckinfo cksum] + dict set dict_path_cksum $path cksum_all_opts [dict get $ckinfo opts] + if {[dict exists $ckinfo error]} { + dict set dict_path_cksum $path cksum_error [dict get $ckinfo error] + } + } + } + + return $dict_path_cksum + } + #whether cksum is e.g + proc cksum_is_tag {cksum} { + expr {[string index $cksum 0] eq "<" && [string index $cksum end] eq ">"} + } + proc cksum_filter_opts {args} { + set ck_opt_names [dict keys [cksum_default_opts]] + set ck_opts [dict create] + dict for {k v} $args { + if {$k in $ck_opt_names} { + dict set ck_opts $k $v + } + } + return $ck_opts + } + + #convenience so caller doesn't have to pre-calculate the relative path from the base + #Note semantic difference from fill_relativecksums_from_base_and_relativepathdict (hence get_ vs fill_) + #Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will ignore valid-looking prefilled cksum values + #base is the presumed location to store the checksum file. The caller should retain (normalize if relative) + proc get_relativecksum_from_base {base specifiedpath args} { + if {$base ne ""} { + #targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it + #we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix + if {[file pathtype $specifiedpath] eq "relative"} { + if {[file pathtype $base] eq "relative"} { + set normbase [file normalize $base] + set normtarg [file normalize [file join $normbase $specifiedpath]] + set targetpath $normtarg + set storedpath [punk::mix::util::path_relative $normbase $normtarg] + } else { + set targetpath [file join $base $specifiedpath] + set storedpath $specifiedpath + } + } else { + #specifed absolute + if {[file pathtype $base] eq "relative"} { + #relative to cwd or to specifiedpath? For consistency it should arguably be cwd but a case could be made that when one path is relative it is in reference to the other + #there is a strong possibility that allowing this combination will cause confusion - better to disallow + error "get_relativecksum_from_base error: disallowed pathtype combination. Base must be empty or absolute when specified path is absolute" + } + #both absolute - compute relative path if they share a common prefix + set commonprefix [punk::mix::util::path_common_prefix $base $specifiedpath] + if {$commonprefix eq ""} { + #absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base + error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" + } + set targetpath $specifiedpath + set storedpath [punk::mix::util::path_relative $base $specifiedpath] + + } + } else { + if {[file type $specifiedpath] eq "relative"} { + #if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage + set targetpath [file normalize $specifiedpath] + set storedpath $targetpath + } else { + set targetpath $specifiedpath + set storedpath $targetpath + } + } + + # + #NOTE: specifiedpath can be a relative path (to cwd) when base is empty + #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc + #possibly also: base: somewhere targetpath: ../elsewhere/etc + # + #todo - write tests + + + if {([llength $args] % 2) != 0} { + error "get_relativecksum_from_base error. args supplied must be in the form of key-value pairs. received '$args' " + } + if {[dict exists $args cksum]} { + if {[dict get $args cksum] ne "" && ![cksum_is_tag [dict get $args cksum]]} { + error "get_relativecksum_from_base called with existing cksum value (and is not a tag or empty-value to be replaced) cksum: [dict get $args cksum] Set cksum to be empty, any tag such as or remove the key and try again." + } + } + + + set ckopts [cksum_filter_opts {*}$args] + set ckinfo [cksum_path $targetpath {*}$ckopts] + + set keyvals $args + dict set keyvals cksum [dict get $ckinfo cksum] + dict set keyvals cksum_all_opts [dict get $ckinfo opts] + if {[dict exists $ckinfo error]} { + dict set keyvals cksum_error [dict get $ckinfo error] + } + + #set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop + #storedpath is relative if possible + return [dict create $storedpath $keyvals] + } + + #calculate the runtime checksum and vfs checksums + proc get_all_vfs_build_cksums {path} { + set buildfolder [get_build_workdir $path] + set cksum_base_folder [file dirname $buildfolder] ;#this is the /src folder - a reasonable base for our vfs cksums + set dict_cksums [dict create] + + set buildrelpath [punk::repo::path_strip_alreadynormalized_prefixdepth $buildfolder $cksum_base_folder] + set vfs_tail_list [glob -nocomplain -dir $cksum_base_folder -type d -tails *.vfs] + + foreach vfstail $vfs_tail_list { + set vname [file rootname $vfstail] + dict set dict_cksums $vfstail [list cksum ""] + dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] + } + + set fullpath_buildruntime $buildfolder/buildruntime.exe + + set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] + set ck [dict get $ckinfo_buildruntime cksum] + + + set relpath [file join $buildrelpath "buildruntime.exe"] + dict set dict_cksums $relpath [list cksum $ck] + + set dict_cksums [fill_relativecksums_from_base_and_relativepathdict $cksum_base_folder $dict_cksums] + + return $dict_cksums + } + + proc get_vfs_build_cksums_stored {vfsfolder} { + set vfscontainer [file dirname $vfsfolder] + set buildfolder $vfscontainer/_build + set vfs [file tail $vfsfolder] + set vname [file rootname $vfs] + set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] + set ckfile $buildfolder/$vname.cksums + if {[file exists $ckfile]} { + set data [punk::mix::util::fcat -translation binary $ckfile] + foreach ln [split $data \n] { + if {[string trim $ln] eq ""} {continue} + lassign $ln path cksum + dict set dict_vfs $path $cksum + } + } + return $dict_vfs + } + proc get_all_build_cksums_stored {path} { + set buildfolder [get_build_workdir $path] + + set vfscontainer [file dirname $buildfolder] + set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] + set dict_cksums [dict create] + foreach vfs $vfslist { + set vname [file rootname $vfs] + set dict_vfs [get_vfs_build_cksums_stored $vfscontainer/$vfs] + + dict set dict_cksums $vname $dict_vfs + } + return $dict_cksums + } + + proc store_vfs_build_cksums {vfsfolder} { + if {![file isdirectory $vfsfolder]} { + error "Unable to find supplied vfsfolder: $vfsfolder" + } + set vfscontainer [file dirname $vfsfolder] + set buildfolder $vfscontainer/_build + set dict_vfs [get_vfs_build_cksums $vfsfolder] + set data "" + dict for {path cksum} $dict_vfs { + append data "$path $cksum" \n + } + set fd [open $buildfolder/$vname.cksums w] + chan configure $fd -translation binary + puts $fd $data + close $fd + return $dict_vfs + } + + + + } +} diff --git a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm index 1ca4cc14..62e366c1 100644 --- a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm +++ b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm @@ -73,7 +73,7 @@ namespace eval punk::mix::commandset::layout { set glob * } set layouts [list] - #set tplfolderdict [punk::cap::templates::folders] + #set tplfolderdict [punk::cap::call_handler punk.templates folders] set tplfolderdict [punk::mix::base::lib::get_template_basefolders] dict for {tdir folderinfo} $tplfolderdict { set layout_base $tdir/layouts diff --git a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index d7150abc..06cddf45 100644 --- a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -305,7 +305,7 @@ namespace eval punk::mix::commandset::project { #todo - tag substitutions in src/doc tree - cd $projectdir + ::cd $projectdir if {[file exists $projectdir/src/modules]} { foreach m $opt_modules { @@ -323,7 +323,7 @@ namespace eval punk::mix::commandset::project { #generate www/man/md output in 'embedded' folder which should be checked into repo for online documentation if {[file exists $projectdir/src]} { - cd $projectdir/src + ::cd $projectdir/src #---------- set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] $installer set_source_target $projectdir/src/doc $projectdir/src/embedded @@ -357,7 +357,7 @@ namespace eval punk::mix::commandset::project { $installer destroy } - cd $projectdir + ::cd $projectdir if {![punk::repo::is_fossil_root $projectdir]} { set first_fossil 1 @@ -742,7 +742,7 @@ namespace eval punk::mix::commandset::project { set workingdir [lindex $workdirs 0] puts stdout "1 result. Changing dir to $workingdir" if {[file exists $workingdir]} { - cd $workingdir + ::cd $workingdir return $workingdir } else { puts stderr "path $workingdir doesn't appear to exist" @@ -753,7 +753,7 @@ namespace eval punk::mix::commandset::project { if {[string trim $answer] in $col_rowids} { set index [expr {$answer - 1}] set workingdir [lindex $workdirs $index] - cd $workingdir + ::cd $workingdir puts stdout [pmix stat] return $workingdir } diff --git a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/templates-0.1.0.tm b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/templates-0.1.0.tm index d4847541..8d525177 100644 --- a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/templates-0.1.0.tm +++ b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/templates-0.1.0.tm @@ -23,10 +23,43 @@ package require punk::cap # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::mix::templates { + variable pkg punk::mix::templates + variable cap_provider + punk::cap::register_package punk::mix::templates [list\ - {templates {relpath ../templates}}\ + {punk.templates {relpath ../templates}}\ ] - + namespace eval capsystem { + if {[info commands capprovider.registration] eq ""} { + punk::cap::interface_capprovider.registration create capprovider.registration + oo::objdefine capprovider.registration { + method get_declarations {} { + set decls [list] + lappend decls punk.templates {relpath ../templates} + lappend decls punk.templates {relpath ../templates2} + return $decls + } + } + } + } + + if {[info commands provider] eq ""} { + punk::cap::interface_capprovider.provider create provider + oo::objdefine provider { + method register {{capabilityname_glob *}} { + #puts registering punk::mix::templates $capabilityname + next + } + method capabilities {} { + next + } + } + } + + # -- --- + #provider api + # -- --- + #none - declarations only } diff --git a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/overlay-0.1.tm b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/overlay-0.1.tm index 9ee458bf..23e69344 100644 --- a/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/overlay-0.1.tm +++ b/src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/overlay-0.1.tm @@ -1,158 +1,158 @@ - - -package require punk::mix::util - -namespace eval ::punk::overlay { - #based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend - # extend an ensemble-like routine with the routines in some namespace - # - # e.g custom_from_base ::punk::mix::cli ::punk::mix::base - # - proc custom_from_base {routine base} { - if {![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 - ] - ] - - punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util - #namespace eval ${routine}::util { - #namespace import ::punk::mix::util::* - #} - punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib - #namespace eval ${routine}::lib [string map [list $base] { - # namespace import ::lib::* - #}] - - namespace eval ${routine}::lib [string map [list $base $routine] { - if {[namespace exists ::lib]} { - set current_paths [namespace path] - if {"" ni $current_paths} { - lappend current_paths - } - namespace path $current_paths - } - }] - - 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 - } - #load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix - #Note: commandset may be imported by different CLIs with different bases *at the same time* - #so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) - #we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. - #commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they - #want the convenience of using lib:xxx with commands coming from those packages. - #This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. - #The basic principle is that the commandset is loaded into the caller(s) with a prefix - #- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) - proc import_commandset {prefix separator cmdnamespace} { - set bad_seps [list "::"] - if {$separator in $bad_seps} { - error "import_commandset invalid separator '$separator'" - } - #namespace may or may not be a package - # allow with or without leading :: - if {[string range $cmdnamespace 0 1] eq "::"} { - set cmdpackage [string range $cmdnamespace 2 end] - } else { - set cmdpackage $cmdnamespace - set cmdnamespace ::$cmdnamespace - } - - if {![namespace exists $cmdnamespace]} { - #only do package require if the namespace not already present - catch {package require $cmdpackage} pkg_load_info - #recheck - if {![namespace exists $cmdnamespace]} { - set prov [package provide $cmdpackage] - if {[string length $prov]} { - set provinfo "(package $cmdpackage is present with version $prov)" - } else { - set provinfo "(package $cmdpackage not present)" - } - error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" - } - } - - punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util - - #let child namespace 'lib' resolve parent namespace and thus util::xxx - namespace eval ${cmdnamespace}::lib [string map [list $cmdnamespace] { - set nspaths [namespace path] - if {"" ni $nspaths} { - lappend nspaths - } - namespace path $nspaths - }] - - set imported_commands [list] - set nscaller [uplevel 1 [list namespace current]] - if {[catch { - namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] - foreach cmd [info commands ${nscaller}::temp_import::*] { - set cmdtail [namespace tail $cmd] - if {$cmdtail eq "_default"} { - set import_as ${nscaller}::${prefix} - } else { - set import_as ${nscaller}::${prefix}${separator}${cmdtail} - } - rename $cmd $import_as - lappend imported_commands $import_as - } - } errM]} { - puts stderr "Error loading commandset $prefix $separator $cmdnamespace" - puts stderr "err: $errM" - } - return $imported_commands - } -} - - -package provide punk::overlay [namespace eval punk::overlay { - variable version - set version 0.1 -}] + + +package require punk::mix::util + +namespace eval ::punk::overlay { + #based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend + # extend an ensemble-like routine with the routines in some namespace + # + # e.g custom_from_base ::punk::mix::cli ::punk::mix::base + # + proc custom_from_base {routine base} { + if {![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 + ] + ] + + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util + #namespace eval ${routine}::util { + #namespace import ::punk::mix::util::* + #} + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib + #namespace eval ${routine}::lib [string map [list $base] { + # namespace import ::lib::* + #}] + + namespace eval ${routine}::lib [string map [list $base $routine] { + if {[namespace exists ::lib]} { + set current_paths [namespace path] + if {"" ni $current_paths} { + lappend current_paths + } + namespace path $current_paths + } + }] + + 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 + } + #load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix + #Note: commandset may be imported by different CLIs with different bases *at the same time* + #so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) + #we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. + #commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they + #want the convenience of using lib:xxx with commands coming from those packages. + #This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. + #The basic principle is that the commandset is loaded into the caller(s) with a prefix + #- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) + proc import_commandset {prefix separator cmdnamespace} { + set bad_seps [list "::"] + if {$separator in $bad_seps} { + error "import_commandset invalid separator '$separator'" + } + #namespace may or may not be a package + # allow with or without leading :: + if {[string range $cmdnamespace 0 1] eq "::"} { + set cmdpackage [string range $cmdnamespace 2 end] + } else { + set cmdpackage $cmdnamespace + set cmdnamespace ::$cmdnamespace + } + + if {![namespace exists $cmdnamespace]} { + #only do package require if the namespace not already present + catch {package require $cmdpackage} pkg_load_info + #recheck + if {![namespace exists $cmdnamespace]} { + set prov [package provide $cmdpackage] + if {[string length $prov]} { + set provinfo "(package $cmdpackage is present with version $prov)" + } else { + set provinfo "(package $cmdpackage not present)" + } + error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" + } + } + + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util + + #let child namespace 'lib' resolve parent namespace and thus util::xxx + namespace eval ${cmdnamespace}::lib [string map [list $cmdnamespace] { + set nspaths [namespace path] + if {"" ni $nspaths} { + lappend nspaths + } + namespace path $nspaths + }] + + set imported_commands [list] + set nscaller [uplevel 1 [list namespace current]] + if {[catch { + namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] + foreach cmd [info commands ${nscaller}::temp_import::*] { + set cmdtail [namespace tail $cmd] + if {$cmdtail eq "_default"} { + set import_as ${nscaller}::${prefix} + } else { + set import_as ${nscaller}::${prefix}${separator}${cmdtail} + } + rename $cmd $import_as + lappend imported_commands $import_as + } + } errM]} { + puts stderr "Error loading commandset $prefix $separator $cmdnamespace" + puts stderr "err: $errM" + } + return $imported_commands + } +} + + +package provide punk::overlay [namespace eval punk::overlay { + variable version + set version 0.1 +}] diff --git a/src/mixtemplates/layouts/basic/src/make.tcl b/src/mixtemplates/layouts/basic/src/make.tcl index e942ebe7..ce8124f9 100644 --- a/src/mixtemplates/layouts/basic/src/make.tcl +++ b/src/mixtemplates/layouts/basic/src/make.tcl @@ -259,84 +259,110 @@ if {$::punkmake::command eq "bootsupport"} { proc bootsupport_localupdate {projectroot} { set bootsupport_modules [list] + set bootsupport_module_folders [list] set bootsupport_config $projectroot/src/bootsupport/include_modules.config ;# if {[file exists $bootsupport_config]} { + set targetroot $projectroot/src/bootsupport/modules source $bootsupport_config ;#populate $bootsupport_modules with project-specific list if {![llength $bootsupport_modules]} { puts stderr "No local bootsupport modules configured for updating" - return - } - set targetroot $projectroot/src/bootsupport/modules - - if {[catch { - #---------- - set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] - $boot_installer set_source_target $projectroot $projectroot/src/bootsupport - set boot_event [$boot_installer start_event {-make_step bootsupport}] - #---------- - } errM]} { - puts stderr "Unable to use punkcheck for bootsupport error: $errM" - set boot_event "" - } + } else { - foreach {relpath module} $bootsupport_modules { - set module [string trim $module :] - set module_subpath [string map [list :: /] [namespace qualifiers $module]] - set srclocation [file join $projectroot $relpath $module_subpath] - #puts stdout "$relpath $module $module_subpath $srclocation" - set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] - #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 - if {![llength $pkgmatches]} { - puts stderr "Missing source for bootsupport module $module - not found in $srclocation" - continue - } - set latestfile [lindex $pkgmatches 0] - set latestver [lindex [split [file rootname $latestfile] -] 1] - foreach m $pkgmatches { - lassign [split [file rootname $m] -] _pkg ver - #puts "comparing $ver vs $latestver" - if {[package vcompare $ver $latestver] == 1} { - set latestver $ver - set latestfile $m - } - } - set srcfile [file join $srclocation $latestfile] - set tgtfile [file join $targetroot $module_subpath $latestfile] - if {$boot_event ne ""} { + if {[catch { #---------- - $boot_event targetset_init INSTALL $tgtfile - $boot_event targetset_addsource $srcfile + set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] + $boot_installer set_source_target $projectroot $projectroot/src/bootsupport + set boot_event [$boot_installer start_event {-make_step bootsupport}] #---------- - if {\ - [llength [dict get [$boot_event targetset_source_changes] changed]]\ - || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ - } { - file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists - $boot_event targetset_started - # -- --- --- --- --- --- - puts "BOOTSUPPORT update: $srcfile -> $tgtfile" - if {[catch { - file copy -force $srcfile $tgtfile - } errM]} { - $boot_event targetset_end FAILED + } errM]} { + puts stderr "Unable to use punkcheck for bootsupport error: $errM" + set boot_event "" + } + + foreach {relpath module} $bootsupport_modules { + set module [string trim $module :] + set module_subpath [string map [list :: /] [namespace qualifiers $module]] + set srclocation [file join $projectroot $relpath $module_subpath] + #puts stdout "$relpath $module $module_subpath $srclocation" + set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] + #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 + if {![llength $pkgmatches]} { + puts stderr "Missing source for bootsupport module $module - not found in $srclocation" + continue + } + set latestfile [lindex $pkgmatches 0] + set latestver [lindex [split [file rootname $latestfile] -] 1] + foreach m $pkgmatches { + lassign [split [file rootname $m] -] _pkg ver + #puts "comparing $ver vs $latestver" + if {[package vcompare $ver $latestver] == 1} { + set latestver $ver + set latestfile $m + } + } + set srcfile [file join $srclocation $latestfile] + set tgtfile [file join $targetroot $module_subpath $latestfile] + if {$boot_event ne ""} { + #---------- + $boot_event targetset_init INSTALL $tgtfile + $boot_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$boot_event targetset_source_changes] changed]]\ + || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ + } { + file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists + $boot_event targetset_started + # -- --- --- --- --- --- + puts "BOOTSUPPORT update: $srcfile -> $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $boot_event targetset_end FAILED + } else { + $boot_event targetset_end OK + } + # -- --- --- --- --- --- } else { - $boot_event targetset_end OK + puts -nonewline stderr "." + $boot_event targetset_end SKIPPED } - # -- --- --- --- --- --- + $boot_event end } else { - puts -nonewline stderr "." - $boot_event targetset_end SKIPPED + file copy -force $srcfile $tgtfile } - $boot_event end - } else { - file copy -force $srcfile $tgtfile + } + if {$boot_event ne ""} { + puts \n + $boot_event destroy + $boot_installer destroy } } - if {$boot_event ne ""} { - puts \n - $boot_event destroy - $boot_installer destroy + + foreach folder $bootsupport_module_folders { + #explicitly ignore punk/mix/templates folder even if specified in config. + #punk/mix/templates contains modules including punk/mix/templates itself - the actual templates aren't needed for the bootsupport system, + # as make.tcl shouldn't be building new projects from the one being made. + #review. + #should we be autodetecting such recursive folder structures - (or is the bootsupport copying in need of a rethink?) + if {[string trim $folder /] eq "punk/mix/templates"} { + puts stderr "IGNORING punk/mix/templates - not needed/desirable in bootsupport" + continue + } + set src [file join $projectroot/modules $folder] + if {![file isdirectory $src]} { + puts stderr "bootsupport folder not found: $src" + continue + } + set tgt [file join $targetroot $folder] + file mkdir $tgt + + puts stdout "BOOTSUPPORT non_tm_files $src - copying to $tgt (if source file changed)" + set overwrite "installedsourcechanged-targets" + set resultdict [punkcheck::install_non_tm_files $src $tgt -installer make.tcl -overwrite $overwrite -punkcheck_folder $projectroot/src/bootsupport] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] } + } } diff --git a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm b/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm index aa1cfde0..cc4e488e 100644 --- a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm +++ b/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm @@ -40,18 +40,18 @@ namespace eval punk::cap::handlers::templates { method pkg_register {pkg capname capdict caplist} { #caplist may not be complete set - which somewhat reduces its utility here regarding any decisions based on the context of this capname/capdict (review - remove this arg?) if {![dict exists $capdict relpath]} { - puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of 'templates' capability, but is missing 'relpath' key" + puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing 'relpath' key" return 0 } set provide_statement [package ifneeded $pkg [package require $pkg]] set tmfile [lindex $provide_statement end] if {![file exists $tmfile]} { - puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of 'templates' capability" + puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" return 0 } set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder if {![file isdirectory $tpath]} { - puts stderr "punk::cap::handlers::templates::capsystem pkg_register WARNING - unable to determine relpath location [dict get $capdict relpath] for package '$pkg' which is attempting to register with punk::cap as a provider of 'templates' capability" + puts stderr "punk::cap::handlers::templates::capsystem pkg_register WARNING - unable to validate relpath location [dict get $capdict relpath] ($tpath) for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" } if {$capname ni $::punk::cap::handlers::templates::handled_caps} { lappend ::punk::cap::handlers::templates::handled_caps $capname diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/oolib-0.1.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/oolib-0.1.tm index 9cf1ca07..3756fceb 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/oolib-0.1.tm +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/oolib-0.1.tm @@ -1,195 +1,195 @@ -#JMN - api should be kept in sync with package patternlib where possible -# -package provide oolib [namespace eval oolib { - variable version - set version 0.1 -}] - -namespace eval oolib { - oo::class create collection { - variable o_data ;#dict - variable o_alias - constructor {} { - set o_data [dict create] - } - method info {} { - return [dict info $o_data] - } - method count {} { - return [dict size $o_data] - } - method isEmpty {} { - expr {[dict size $o_data] == 0} - } - method names {{globOrIdx {}}} { - if {[llength $globOrIdx]} { - if {[string is integer -strict $globOrIdx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $idx} result]} { - error "[self object] no such index : '$idx'" - } else { - return $result - } - } else { - #glob - return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] - } - } else { - return [dict keys $o_data] - } - } - #like names but without globbing - method keys {} { - dict keys $o_data - } - method key {{posn 0}} { - if {$posn < 0} { - set posn "end-[expr {abs($posn + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $posn} result]} { - error "[self object] no such index : '$posn'" - } else { - return $result - } - } - method hasKey {key} { - dict exists $o_data $key - } - method get {} { - return $o_data - } - method items {} { - return [dict values $o_data] - } - method item {key} { - if {[string is integer -strict $key]} { - if {$key > 0} { - set valposn [expr {(2*$key) +1}] - return [lindex $o_data $valposn] - } else { - set key "end-[expr {abs($key + 1)}]" - return [lindex [dict keys $o_data] $key] - } - } - if {[dict exists $o_data $key]} { - return [dict get $o_data $key] - } - } - #inverse lookup - method itemKeys {value} { - set value_indices [lsearch -all [dict values $o_data] $value] - set keylist [list] - foreach i $value_indices { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - method search {value args} { - set matches [lsearch {*}$args [dict values $o_data] $value] - if {"-inline" in $args} { - return $matches - } else { - set keylist [list] - foreach i $matches { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - } - #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? - method alias {newAlias existingKeyOrAlias} { - if {[string is integer -strict $newAlias]} { - error "[self object] collection key alias cannot be integer" - } - if {[string length $existingKeyOrAlias]} { - set o_alias($newAlias) $existingKeyOrAlias - } else { - unset o_alias($newAlias) - } - } - method aliases {{key ""}} { - if {[string length $key]} { - set result [list] - foreach {n v} [array get o_alias] { - if {$v eq $key} { - lappend result $n $v - } - } - return $result - } else { - return [array get o_alias] - } - } - #if the supplied index is an alias, return the underlying key; else return the index supplied. - method realKey {idx} { - if {[catch {set o_alias($idx)} key]} { - return $idx - } else { - return $key - } - } - method add {value key} { - if {[string is integer -strict $key]} { - error "[self object] collection key must not be an integer. Use another structure if integer keys required" - } - if {[dict exists $o_data $key]} { - error "[self object] col_processors object error: key '$key' already exists in collection" - } - dict set o_data $key $value - return [expr {[dict size $o_data] - 1}] ;#return index of item - } - method remove {idx {endRange ""}} { - if {[string length $endRange]} { - error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" - } - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx+1)}]" - } - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - if {$posn < 0} { - error "[self object] no such index: '$idx' in this collection" - } - } - dict unset o_data $key - return - } - method clear {} { - set o_data [dict create] - return - } - method reverse {} { - set dictnew [dict create] - foreach k [lreverse [dict keys $o_data]] { - dict set dictnew $k [dict get $o_data $k] - } - set o_data $dictnew - return - } - #review - cmd as list vs cmd as script? - method map {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list {*}$cmd $v]] - } - return $seed - } - method objectmap {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list $v {*}$cmd]] - } - return $seed - } - } - -} - +#JMN - api should be kept in sync with package patternlib where possible +# +package provide oolib [namespace eval oolib { + variable version + set version 0.1 +}] + +namespace eval oolib { + oo::class create collection { + variable o_data ;#dict + variable o_alias + constructor {} { + set o_data [dict create] + } + method info {} { + return [dict info $o_data] + } + method count {} { + return [dict size $o_data] + } + method isEmpty {} { + expr {[dict size $o_data] == 0} + } + method names {{globOrIdx {}}} { + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "[self object] no such index : '$idx'" + } else { + return $result + } + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } + } + #like names but without globbing + method keys {} { + dict keys $o_data + } + method key {{posn 0}} { + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "[self object] no such index : '$posn'" + } else { + return $result + } + } + method hasKey {key} { + dict exists $o_data $key + } + method get {} { + return $o_data + } + method items {} { + return [dict values $o_data] + } + method item {key} { + if {[string is integer -strict $key]} { + if {$key > 0} { + set valposn [expr {(2*$key) +1}] + return [lindex $o_data $valposn] + } else { + set key "end-[expr {abs($key + 1)}]" + return [lindex [dict keys $o_data] $key] + } + } + if {[dict exists $o_data $key]} { + return [dict get $o_data $key] + } + } + #inverse lookup + method itemKeys {value} { + set value_indices [lsearch -all [dict values $o_data] $value] + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + method search {value args} { + set matches [lsearch {*}$args [dict values $o_data] $value] + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + } + #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? + method alias {newAlias existingKeyOrAlias} { + if {[string is integer -strict $newAlias]} { + error "[self object] collection key alias cannot be integer" + } + if {[string length $existingKeyOrAlias]} { + set o_alias($newAlias) $existingKeyOrAlias + } else { + unset o_alias($newAlias) + } + } + method aliases {{key ""}} { + if {[string length $key]} { + set result [list] + foreach {n v} [array get o_alias] { + if {$v eq $key} { + lappend result $n $v + } + } + return $result + } else { + return [array get o_alias] + } + } + #if the supplied index is an alias, return the underlying key; else return the index supplied. + method realKey {idx} { + if {[catch {set o_alias($idx)} key]} { + return $idx + } else { + return $key + } + } + method add {value key} { + if {[string is integer -strict $key]} { + error "[self object] collection key must not be an integer. Use another structure if integer keys required" + } + if {[dict exists $o_data $key]} { + error "[self object] col_processors object error: key '$key' already exists in collection" + } + dict set o_data $key $value + return [expr {[dict size $o_data] - 1}] ;#return index of item + } + method remove {idx {endRange ""}} { + if {[string length $endRange]} { + error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" + } + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx+1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + error "[self object] no such index: '$idx' in this collection" + } + } + dict unset o_data $key + return + } + method clear {} { + set o_data [dict create] + return + } + method reverse {} { + set dictnew [dict create] + foreach k [lreverse [dict keys $o_data]] { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + return + } + #review - cmd as list vs cmd as script? + method map {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list {*}$cmd $v]] + } + return $seed + } + method objectmap {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list $v {*}$cmd]] + } + return $seed + } + } + +} + diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap-0.1.0.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap-0.1.0.tm index 6749035a..34bed4c0 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap-0.1.0.tm +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap-0.1.0.tm @@ -19,15 +19,171 @@ ## Requirements ##e.g package require frobz - +#concepts: +# A capability may be something like providing a folder of files, or just a data dictionary, and/or an API +# +# capability handler - a package/namespace which may provide validation and standardised ways of looking up provider data +# registered (or not) using register_capabilityname +# capability provider - a package which registers as providing one or more capablities. +# registered using register_package +# the capabilitylist is a list of 2-element lists where the first element is the capabilityname and the second element is a (possibly empty) dict of data relevant to that capability +# A capabilityname may appear multiple times. ie a package may register that it provides the capability with multiple datasets. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::cap { - variable pkgcap [dict create] + variable pkgcapsdeclared [dict create] + variable pkgcapsaccepted [dict create] variable caps [dict create] + if {[info commands [namespace current]::interface_caphandler.registry] eq ""} { + oo::class create [namespace current]::interface_caphandler.registry { + method pkg_register {pkg capname capdict fullcapabilitylist} { + #handler may override and return 0 (indicating don't register)e.g if pkg capdict data wasn't valid + #overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. + return 1 ;#default to permit + } + method pkg_unregister {pkg} { + return ;#unregistration return is ignored - review + } + } + + oo::class create [namespace current]::interface_capprovider.registration { + method get_declarations {} { + error "interface_capprovider.registration not implemented by provider" + } + } + oo::class create [namespace current]::interface_capprovider.provider { + method register {{capabilityname_glob *}} { + + } + method capabilities {} { + + } + } + } + #Not all capabilities have to be registered. + #A package registering as a provider using register_package can include capabilitynames in it's capabilitylist which have no associated capnamespace (handler). + #such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. + #we allow registering a capability with an empty handler (capnamespace) - but this means another handler could be registered later. + proc register_capabilityname {capname capnamespace} { + variable caps + variable pkgcapsdeclared + variable pkgcapsaccepted + if {$capnamespace ne ""} { + #normalize with leading :: in case caller passed in package name rather than fully qualified namespace + if {![string match ::* $capnamespace]} { + set capnamespace ::$capnamespace + } + } + #allow register of existing capname iff there is no current handler + #as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package + #we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers + if {[set hdlr [get_handler $capname]] ne ""} { + error "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" + } + #assert: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries. + dict set caps $capname handler $capnamespace + if {![dict exists $caps $capname providers]} { + dict set caps $capname providers [list] + } + if {[llength [set providers [dict get $caps $capname providers]]]} { + #some provider(s) were in place before the handler was registered + if {[set capreg [get_caphandler_registry $capname]] ne ""} { + foreach pkg $providers { + set fullcapabilitylist [dict get $pkgcapsdeclared $pkg] + foreach capspec $fullcapabilitylist { + lassign $capspec cn capdict + if {$cn ne $capname} { + continue + } + set do_register [$capreg pkg_register $pkg $capdict $fullcapabilitylist] + set list_accepted [dict get $pkgcapsaccepted $pkg] + if {$do_register} { + if {$capspec ni $list_accepted} { + dict lappend pkgcapsaccepted $pkg $capspec + } + } else { + set posn [lsearch $list_accepted $capspec] + if {$posn >=0} { + set list_accepted [lreplace $list_accepted $posn $posn] + dict set pkgcapsaccepted $pkg $list_accepted + } + } + } + #check if any accepted for this cap and remove from caps as necessary + set count 0 + foreach accepted_capspec [dict get $pkgcapsaccepted $pkg] { + if {[lindex $accepted_capspec 0] eq $capname} { + incr count + } + } + if {$count == 0} { + set pkgposn [lsearch $providers $pkg] + if {$pkgposn >= 0} { + set updated_providers [lreplace $providers $posn $posn] + dict set caps $capname providers $updated_providers + } + } + } + + } + + } + } + proc exists {capname} { + variable caps + return [dict exists $caps $capname] + } + proc has_handler {capname} { + variable caps + return [expr {[dict exists $caps $capname handler] && [dict get $caps $capname handler] ne ""}] + } + proc get_handler {capname} { + variable caps + if {[dict exists $caps $capname]} { + return [dict get $caps $capname handler] + } + return "" + } + + #dispatch + #proc call_handler {capname args} { + # if {[set handler [get_handler $capname]] eq ""} { + # error "punk::cap::call_handler $capname $args - no handler registered for capability $capname" + # } + # ${handler}::[lindex $args 0] {*}[lrange $args 1 end] + #} + proc call_handler {capname args} { + if {[set handler [get_handler $capname]] eq ""} { + error "punk::cap::call_handler $capname $args - no handler registered for capability $capname" + } + set obj ${handler}::$capname + $obj [lindex $args 0] {*}[lrange $args 1 end] + } + proc get_caphandler_registry {capname} { + set ns [get_handler $capname]::capsystem + if {[namespace exists ${ns}]} { + if {[info command ${ns}::caphandler.registry] ne ""} { + if {[info object isa object ${ns}::caphandler.registry]} { + return ${ns}::caphandler.registry + } + } + } + return "" + } + proc get_providers {capname} { + variable caps + if {[dict exists $caps $capname]} { + return [dict get $caps $capname providers] + } + return [list] + } + + #register package with arbitrary capnames from capabilitylist + #The registered pkg is a module that provides some service to that capname. Possibly just data members, that the capability will use. proc register_package {pkg capabilitylist} { - variable pkgcap + variable pkgcapsdeclared + variable pkgcapsaccepted variable caps if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] @@ -35,165 +191,209 @@ namespace eval punk::cap { #for each capability # - ensure 1st element is a single word # - ensure that if 2nd element (capdict) is present - it is dict shaped - foreach c $capabilitylist { - lassign $c capname capdict + foreach capspec $capabilitylist { + lassign $capspec capname capdict if {[llength $capname] !=1} { - error "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$c'" + error "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$capspec'" } if {[expr {[llength $capdict] %2 != 0}]} { - error "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$c'" + error "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$capspec'" } if {[dict exists $caps $capname]} { - set cap_pkgs [dict get $caps $capname] + set cap_pkgs [dict get $caps $capname providers] } else { + dict set caps $capname [dict create handler "" providers [list]] set cap_pkgs [list] } - if {$pkg ni $cap_pkgs} { - dict lappend caps $capname $pkg + #todo - if there's a caphandler - call it's init/validation callback for the pkg + set do_register 1 ;#default assumption unless vetoed by handler + if {[set capreg [get_caphandler_registry $capname]] ne ""} { + #Note that the interface_caphandler.registry instance must be able to handle multiple calls for same pkg + set do_register [$capreg pkg_register $pkg $capname $capdict $capabilitylist] + } + if {$do_register} { + if {$pkg ni $cap_pkgs} { + lappend cap_pkgs $pkg + dict set caps $capname providers $cap_pkgs + } + dict lappend pkgcapsaccepted $pkg $capspec ;#if pkg is being registered prior to handler-registration - the handler may undo this entry } } - dict set pkgcap $pkg $capabilitylist + #another call to register_pkg with same pkg may have been made (most likely with different capname) so we must append + #dict lappend pkgcapsdeclared $pkg $capabilitylist + if {[dict exists $pkgcapsdeclared $pkg]} { + set caps [dict get $pkgcapsdeclared $pkg] + lappend caps {*}$capabilitylist + dict set pkgcapsdeclared $pkg $caps + } else { + dict set pkgcapsdeclared $pkg $capabilitylist + } } + proc unregister_package {pkg} { + variable pkgcapsdeclared + variable caps + if {[string match ::* $pkg]} { + set pkg [string range $pkg 2 end] + } + if {[dict exists $pkgcapsdeclared $pkg]} { + #remove corresponding entries in caps + set capabilitylist [dict get $pkgcapsdeclared $pkg] + foreach c $capabilitylist { + set do_unregister 1 + lassign $c capname _capdict + set cap_info [dict get $caps $capname] + set pkglist [dict get $cap_info providers] + set posn [lsearch $pkglist $pkg] + if {$posn >= 0} { + if {[set capreg [get_caphandler_registry $capname]] ne ""} { + #review + # it seems not useful to allow the callback to block this unregister action + #the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter + #vetoing unregister would make this more complex for no particular advantage + #if per capability deregistration required this should probably be a separate thing (e.g disable_capability?) + $capreg pkg_unregister $pkg + } + set pkglist [lreplace $pkglist $posn $posn] + dict set caps $capname providers $pkglist + } + } + #delete the main registration record + dict unset pkgcapsdeclared $pkg + } + } + + #review promote/demote doesn't always make a lot of sense .. should possibly be per cap for multicap pkgs + #The idea is to provide a crude way to preference/depreference packages independently of order the packages were loaded + #e.g a caller or cap-handler can ascribe some meaning to the order of the 'providers' key returned from punk::cap::capabilities + #The order of providers will be the order the packages were loaded & registered + #the naming: "promote vs demote" operates on a latest-package-in-list has higher preference assumption (matching last pkg loaded) + #Each capability handler could implement specific preferencing methods if finer control needed. + #In some cases the preference/loading order may be inapplicable/irrelevant to a particular capability anyway. + #As this is just a basic mechanism, which can't support independent per-cap preferencing for multi-cap packages - + # it only allows putting the pkgs to the head or tail of the lists. + #Whether particular caps or users of caps do anything with this ordering is dependent on the cap-handler and/or calling code. proc promote_package {pkg} { - variable pkgcap + variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] } - if {![dict exists $pkgcap $pkg]} { + if {![dict exists $pkgcapsdeclared $pkg]} { error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" } - if {[dict size $pkgcap] > 1} { - set pkginfo [dict get $pkgcap $pkg] + if {[dict size $pkgcapsdeclared] > 1} { + set pkginfo [dict get $pkgcapsdeclared $pkg] #remove and re-add at end of dict - dict unset pkgcap $pkg - dict set pkgcap $pkg $pkginfo - foreach {cap cap_pkgs} $caps { + dict unset pkgcapsdeclared $pkg + dict set pkgcapsdeclared $pkg $pkginfo + dict for {cap cap_info} $caps { + set cap_pkgs [dict get $cap_info providers] if {$pkg in $cap_pkgs} { set posn [lsearch $cap_pkgs $pkg] if {$posn >=0} { #rewrite package list with pkg at tail of list for this capability set cap_pkgs [lreplace $cap_pkgs $posn $posn] lappend cap_pkgs $pkg - dict set caps $cap $cap_pkgs + dict set caps $cap providers $cap_pkgs } } } } } proc demote_package {pkg} { - variable pkgcap + variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] } - if {![dict exists $pkgcap $pkg]} { + if {![dict exists $pkgcapsdeclared $pkg]} { error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" } - if {[dict size $pkgcap] > 1} { - set pkginfo [dict get $pkgcap $pkg] + if {[dict size $pkgcapsdeclared] > 1} { + set pkginfo [dict get $pkgcapsdeclared $pkg] #remove and re-add at start of dict - dict unset pkgcap $pkg - dict set pkgcap $pkg $pkginfo - set pkgcap [dict merge [dict create $pkg $pkginfo] $pkgcap] - foreach {cap cap_pkgs} $caps { + dict unset pkgcapsdeclared $pkg + dict set pkgcapsdeclared $pkg $pkginfo + set pkgcapsdeclared [dict merge [dict create $pkg $pkginfo] $pkgcapsdeclared] + dict for {cap cap_info} $caps { + set cap_pkgs [dict get $cap_info providers] if {$pkg in $cap_pkgs} { set posn [lsearch $cap_pkgs $pkg] if {$posn >=0} { #rewrite package list with pkg at head of list for this capability set cap_pkgs [lreplace $cap_pkgs $posn $posn] set cap_pkgs [list $pkg {*}$cap_pkgs] - dict set caps $cap $cap_pkgs + dict set caps $cap providers $cap_pkgs } } } } } - proc unregister_package {pkg} { - variable pkgcap - variable caps + proc pkgcap {pkg} { + variable pkgcapsdeclared + variable pkgcapsaccepted if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] } - if {[dict exists $pkgcap $pkg]} { - #remove corresponding entries in caps - set capabilitylist [dict get $pkgcap $pkg] - foreach c $capabilitylist { - lassign $c capname _capdict - set pkglist [dict get $caps $capname] - set posn [lsearch $pkglist $pkg] - if {$posn >= 0} { - set pkglist [lreplace $pkglist $posn $posn] - dict set caps $capname $pkglist - } + if {[dict exists $pkgcapsdeclared $pkg]} { + set accepted "" + if {[dict exists $pkgcapsaccepted $pkg]} { + set accepted [dict get $pkgcapsaccepted $pkg] } - #delete the main registration record - dict unset pkgcap $pkg - } - } - proc registered_package {pkg} { - variable pkgcap - if {[string match ::* $pkg]} { - set pkg [string range $pkg 2 end] - } - if {[dict exists $pkgcap $pkg]} { - return [dict get $pkgcap $pkg] + return [dict create declared [dict get $pkgcapsdeclared $pkg] accepted $accepted] } else { return } } - proc registered_packages {} { - variable pkgcap - return $pkgcap + proc pkgcaps {} { + variable pkgcapsdeclared + variable pkgcapsaccepted + set result [dict create] + foreach {pkg capsdeclared} $pkgcapsdeclared { + set accepted "" + if {[dict exists $pkgcapsaccepted $pkg]} { + set accepted [dict get $pkgcapsaccepted $pkg] + } + dict set result $pkg declared $capsdeclared + dict set result $pkg accepted $accepted + } + return $result } + proc capability {capname} { + variable caps + if {[dict exists $caps $capname]} { + return [dict get $caps $capname] + } + return "" + } proc capabilities {{glob *}} { variable caps - set keys [lsort [dict keys $caps $glob]] + set capnames [lsort [dict keys $caps $glob]] set cap_list [list] - foreach k $keys { - lappend cap_list [list $k [dict get $caps $k]] + foreach capname $capnames { + lappend cap_list [list $capname [dict get $caps $capname]] } return $cap_list } - namespace eval templates { - #return a dict keyed on folder with source pkg as value - proc folders {} { - package require punk::cap - set caplist [punk::cap::capabilities templates] - # e.g {templates {punk::mix::templates ::somepkg}} - set templates_record [lindex $caplist 0] - set pkgs [lindex $templates_record 1] - - set folderdict [dict create] - foreach pkg $pkgs { - set caplist [punk::cap::registered_package $pkg] - set templates_entries [lsearch -all -inline -index 0 $caplist templates] ;#we generally expect only one - but if multiple exist - use them - foreach templates_info $templates_entries { - lassign $templates_info _templates templates_dict - if {[dict exists $templates_dict relpath]} { - set provide_statement [package ifneeded $pkg [package require $pkg]] - set tmfile [lindex $provide_statement end] - #set tmdir [file dirname [lindex $provide_statement end]] - set tpath [file normalize [file join $tmfile [dict get $templates_dict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder - #relpath relative to file is important for tm files that are zip/tar based containers - if {[file isdirectory $tpath]} { - dict set folderdict $tpath [list source $pkg sourcetype package] - } else { - puts stderr "punk::cap::templates::folders WARNING - unable to determine base folder for package '$pkg' which is registered with punk::mix as a provider of 'templates' capability" - } - } else { - puts stderr "punk::cap::templates::folders WARNING - registered pkg 'pkg' has capability 'templates' but no 'relpath' key - unable to use as source of templates" - } - } + proc capabilitynames {{glob *}} { + variable caps + return [lsort [dict keys $caps $glob]] + } + #return only those capnames which have at least one provider + proc capabilitynames_provided {{glob *}} { + variable caps + set keys [lsort [dict keys $caps $glob]] + set cap_list [list] + foreach k $keys { + if {[llength [dict get $caps $k providers]] > 0} { + lappend cap_list $k } - return $folderdict } - - - + return $cap_list } + } diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm new file mode 100644 index 00000000..8fdce944 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm @@ -0,0 +1,52 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -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) 2023 +# +# @@ Meta Begin +# Application punk::cap::handlers::caphandler 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::cap::handlers::caphandler { + + + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::cap::handlers::caphandler [namespace eval punk::cap::handlers::caphandler { + variable pkg punk::cap::handlers::caphandler + variable version + set version 0.1.0 +}] +return \ No newline at end of file diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap/handlers/scriptlibs-0.1.0.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap/handlers/scriptlibs-0.1.0.tm new file mode 100644 index 00000000..8298ec18 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap/handlers/scriptlibs-0.1.0.tm @@ -0,0 +1,52 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -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) 2023 +# +# @@ Meta Begin +# Application punk::cap::handlers::scriptlibs 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::cap::handlers::scriptlibs { + + + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::cap::handlers::scriptlibs [namespace eval punk::cap::handlers::scriptlibs { + variable pkg punk::cap::handlers::scriptlibs + variable version + set version 0.1.0 +}] +return \ No newline at end of file diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm new file mode 100644 index 00000000..28a25e6f --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm @@ -0,0 +1,127 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -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) 2023 +# +# @@ Meta Begin +# Application punk::cap::handlers::templates 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#register using: +# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates + +#By convention and for consistency, we don't register here during package loading - but require the calling app to do it. +# (even if it tends to be done immediately after package require anyway) +# registering capability handlers can involve validating existing provider data and is best done explicitly as required. +# It is also possible for a capability handler to be registered to handle more than one capabilityname + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::cap::handlers::templates { + namespace eval capsystem { + #interfaces for punk::cap to call into + if {[info commands caphandler.registry] eq ""} { + punk::cap::interface_caphandler.registry create caphandler.registry + oo::objdefine caphandler.registry { + method pkg_register {pkg capname capdict caplist} { + #caplist may not be complete set - which somewhat reduces its utility here regarding any decisions based on the context of this capname/capdict (review - remove this arg?) + if {![dict exists $capdict relpath]} { + puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing 'relpath' key" + return 0 + } + set provide_statement [package ifneeded $pkg [package require $pkg]] + set tmfile [lindex $provide_statement end] + if {![file exists $tmfile]} { + puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" + return 0 + } + set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder + if {![file isdirectory $tpath]} { + puts stderr "punk::cap::handlers::templates::capsystem pkg_register WARNING - unable to validate relpath location [dict get $capdict relpath] ($tpath) for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" + } + if {$capname ni $::punk::cap::handlers::templates::handled_caps} { + lappend ::punk::cap::handlers::templates::handled_caps $capname + } + if {[info commands punk::cap::handlers::templates::$capname] eq ""} { + punk::cap::handlers::templates::api create ::punk::cap::handlers::templates::$capname $capname + } + set cname [string map [list . _] $capname] + upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders + dict lappend pfolders $pkg $tpath + return 1 + } + method pkg_unregister {pkg} { + upvar ::punk::cap::handlers::templates::handled_caps hcaps + foreach capname $hcaps { + set cname [string map [list . _] $capname] + upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders + dict unset pfolders $pkg + #destroy api objects? + } + } + } + } + } + + variable handled_caps [list] + #variable pkg_folders [dict create] + + # -- --- --- --- --- --- --- + #handler api for clients of this capability - called via punk::cap::call_handler ?args? + # -- --- --- --- --- --- --- + namespace export * + + oo::class create api { + #return a dict keyed on folder with source pkg as value + constructor {capname} { + variable capabilityname + variable cname + set cname [string map [list . _] $capname] + set capabilityname $capname + } + method folders {} { + variable capabilityname + variable cname + upvar punk::cap::handlers::templates::pkg_folders_$cname pkg_folders + package require punk::cap + set capinfo [punk::cap::capability $capabilityname] + # e.g {punk.templates {handler punk::mix::templates providers ::somepkg}} + + #use the order of pkgs as registered with punk::cap - may have been modified with punk::cap::promote_package/demote_package + set pkgs [dict get $capinfo providers] + set folderdict [dict create] + foreach pkg $pkgs { + foreach pfolder [dict get $pkg_folders $pkg] { + dict set folderdict $pfolder [list source $pkg sourcetype package] + } + } + return $folderdict + } + } + + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::cap::handlers::templates [namespace eval punk::cap::handlers::templates { + variable pkg punk::cap::handlers::templates + variable version + set version 0.1.0 +}] +return \ No newline at end of file diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix-0.2.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix-0.2.tm index 2988b428..d09dfca8 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix-0.2.tm +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix-0.2.tm @@ -1,6 +1,12 @@ package require punk::cap -package require punk::mix::templates ;#registers 'templates' capability with punk::cap + +package require punk::cap::handlers::templates ;#handler for templates cap +punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates + +package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap +#punk::mix::templates::provider register * + package require punk::mix::base package require punk::mix::cli diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/base-0.1.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/base-0.1.tm index 0f131936..fcfaf56b 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/base-0.1.tm +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/base-0.1.tm @@ -1,904 +1,908 @@ -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] ;#dependency on punk pipeline/patternmatching system - lassign [_split_args $args] _opts opts _args args - if {[dict exists $opts -extension]} { - set extension [dict get $opts -extension] - } else { - set extension "" - } - #--------- - - uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] - } - proc _cli {args} { - #--------- - #extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system - lassign [_split_args $args] _opts opts _args args - if {[dict exists $opts -extension]} { - set extension [dict get $opts -extension] - } else { - set extension "" - } - #--------- - if {![string length $extension]} { - set extension [namespace qualifiers [lindex [info level -1] 0]] - } - #puts stderr "punk::mix::base extension: [string trimleft $extension :]" - if {![string length $extension]} { - #if still no extension - must have been called dirctly as punk::mix::base::_cli - if {![llength $args]} { - set args "help" - } - set extension [namespace current] - } - 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] ;#dependency on punk pipeline/patternmatching system - lassign [_split_args $args] _opts opts _args args - if {[dict exists $opts -extension]} { - set extension [dict get $opts -extension] - } else { - set extension "" - } - #--------- - - 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 "_redirected $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 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] ;#dependency on punk pipeline/patternmatching system - lassign [_split_args $args] _opts opts _args args - if {[dict exists $opts -extension]} { - set extension [dict get $opts -extension] - } else { - set extension "" - } - #--------- - 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 - #' ``` - #' - #' - - - #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> " opts $opts] - } - if {$ftype ni [list file directory]} { - #review - links? - error "cksum_path error file type '$ftype' not supported" - } - - - set opt_cksum_algorithm [dict get $opts -cksum_algorithm] - if {$opt_cksum_algorithm ni [cksum_algorithms]} { - return [list error unsupported_cksum_algorithm cksum "" opts $opts] - } - set opt_cksum_acls [dict get $opts -cksum_acls] - if {$opt_cksum_acls} { - puts stderr "cksum_path is not yet able to cksum ACLs" - return - } - - set opt_cksum_meta [dict get $opts -cksum_meta] - set opt_use_tar [dict get $opts -cksum_usetar] - if {$ftype eq "file"} { - if {$opt_use_tar eq "auto"} { - if {$opt_cksum_meta eq "1"} { - set opt_use_tar 1 - } else { - #prefer no tar if meta not required - faster/simpler - #meta == auto or 0 - set opt_cksum_meta 0 - set opt_use_tar 0 - } - } elseif {$opt_use_tar eq "0"} { - if {$opt_cksum_meta eq "1"} { - puts stderr "cksum_path doesn't yet support a non-tar cksum with metadata for a file" - return [list error unsupported_meta_without_tar cksum "" opts $opts] - } else { - #meta == auto or 0 - set opt_cksum_meta 0 - } - } else { - #tar == 1 - if {$opt_cksum_meta eq "0"} { - puts stderr "cksum_path doesn't yet support a tar cksum without metadata for a file" - return [list error unsupported_tar_without_meta cksum "" opts $opts] - } else { - #meta == auto or 1 - set opt_cksum_meta 1 - } - } - } elseif {$ftype eq "directory"} { - if {$opt_use_tar eq "auto"} { - if {$opt_cksum_meta in [list "auto" "1"]} { - set opt_use_tar 1 - set opt_cksum_meta 1 - } else { - puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto" - return [list error unsupported_directory_cksum_without_meta cksum "" opts $opts] - } - } elseif {$opt_use_tar eq "0"} { - puts stderr "cksum_path doesn't yet support a cksum of a folder structure without tar. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" - return [list error unsupported_directory_cksum_without_tar cksum "" opts $opts] - } else { - #tar 1 - if {$opt_cksum_meta eq "0"} { - puts stderr "cksum_path doesn't yet support a tar checksum of a folder structure without metadat. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" - return [list error unsupported_without_meta cksum "" opts $opts] - } else { - #meta == auto or 1 - set opt_cksum_meta 1 - } - } - } - - dict set opts_actual -cksum_meta $opt_cksum_meta - dict set opts_actual -cksum_usetar $opt_use_tar - - - if {$opt_use_tar} { - package require tar ;#from tcllib - } - - if {$path eq $base} { - #attempting to cksum at root/volume level of a filesystem.. extra work - #This needs fixing for general use.. not necessarily just for project repos - puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" - return [list error unsupported_path opts $opts] - } - - if {$opt_cksum_algorithm eq "sha1"} { - package require sha1 - set cksum_command [list sha1::sha1 -hex -file] - } elseif {$opt_cksum_algorithm in [list "sha2" "sha256"]} { - package require sha256 - set cksum_command [list sha2::sha256 -hex -file] - } elseif {$opt_cksum_algorithm eq "md5"} { - package require md5 - set cksum_command [list md5::md5 -hex -file] - } elseif {$opt_cksum_algorithm eq "cksum"} { - package require cksum ;#tcllib - set cksum_command [list crc::cksum -format 0x%X -file] - } elseif {$opt_cksum_algorithm eq "adler32"} { - set cksum_command [list cksum_adler32_file] - } elseif {$opt_cksum_algorithm in [list "sha3" "sha3-256"]} { - #todo - replace with something that doesn't call another process - #set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] - set cksum_command [list $sha3_implementation 256] - } elseif {$opt_cksum_algorithm in [list "sha3-224" "sha3-384" "sha3-512"]} { - set bits [lindex [split $opt_cksum_algorithm -] 1] - #set cksum_command [list apply {{bits file} {lindex [exec fossil sha3sum -$bits $file] 0}} $bits] - set cksum_command [list $sha3_implementation $bits] - } - - set cksum "" - if {$opt_use_tar != 0} { - set target [file tail $path] - set tmplocation [punk::mix::util::tmpdir] - set archivename $tmplocation/[punk::mix::util::tmpfile].tar - - cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) - - #temp emission to stdout.. todo - repl telemetry channel - puts stdout "cksum_path: creating temporary tar archive at: $archivename .." - tar::create $archivename $target - if {$ftype eq "file"} { - set sizeinfo "(size [file size $target])" - } else { - set sizeinfo "(file type $ftype - size unknown)" - } - puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." - set cksum [{*}$cksum_command $archivename] - #puts stdout "cksum_path: cleaning up.. " - file delete -force $archivename - cd $startdir - - } else { - #todo - if {$ftype eq "file"} { - if {$opt_cksum_meta} { - return [list error unsupported_opts_combo cksum "" opts $opts] - } else { - set cksum [{*}$cksum_command $path] - } - } else { - error "cksum_path unsupported $opts for path type [file type $path]" - } - } - set result [dict create] - dict set result cksum $cksum - dict set result opts $opts_actual - return $result - } - - #dict_path_cksum keyed on path - with value as a dict that must contain cksum key - but can contain other keys - #e.g -cksum_usetar which is one of the keys understood by the punk::mix::base::lib::cksum_path function - or unrelated keys which will also be passed through - #cksum only calculated for keys in dict where cksum is empty - ie return same dict but with empty cksums filled out. - #base can be empty string in which case paths must be absolute - proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { - if {$base eq ""} { - set error_paths [list] - dict for {path pathinfo} $dict_path_cksum { - if {[file pathtype $path] ne "absolute"} { - lappend error_paths $path - } - } - if {[llength $error_paths]} { - puts stderr "get_relativecksums_from_base_and_relativepathdict has empty base - and non-absolute paths in the supplied checksum dict - aborting" - puts stderr "error_paths: $error_paths" - error "fill_relativecksums_from_base_and_relativepathdict error: non-absolute paths when base empty. $error_paths" - } - } else { - if {[file pathtype $base] ne "absolute"} { - error "fill_relativecksums_from_base_and_relativepathdict error: base supplied but was not absolute path. $base" - } - #conversely now we have a base - so we require all paths are relative. - #We will ignore/disallow volume-relative - as these shouldn't be used here either - set error_paths [list] - dict for {path pathinfo} $dict_path_cksum { - if {[file pathtype $path] ne "relative"} { - lappend error_paths $path - } - } - if {[llength $error_paths]} { - puts stderr "fill_relativecksums_from_base_and_relativepathdict has a supplied absolute base path, but some of the paths in the supplied dict are not relative - aborting" - error "fill_relativecksums_from_base_and_relativepathdict error: non-relative paths when base supplied. $error_paths" - } - } - - - dict for {path pathinfo} $dict_path_cksum { - if {![dict exists $pathinfo cksum]} { - dict set pathinfo cksum "" - } else { - if {[dict get $pathinfo cksum] ne "" && ![cksum_is_tag [dict get $pathinfo cksum]]} { - continue ;#already filled with non-tag value - } - } - if {$base ne ""} { - set fullpath [file join $base $path] - } else { - set fullpath $path - } - - set ckopts [cksum_filter_opts {*}$pathinfo] - - if {![file exists $fullpath]} { - dict set dict_path_cksum $path cksum "" - } else { - set ckinfo [cksum_path $fullpath {*}$ckopts] - dict set dict_path_cksum $path cksum [dict get $ckinfo cksum] - dict set dict_path_cksum $path cksum_all_opts [dict get $ckinfo opts] - if {[dict exists $ckinfo error]} { - dict set dict_path_cksum $path cksum_error [dict get $ckinfo error] - } - } - } - - return $dict_path_cksum - } - #whether cksum is e.g - proc cksum_is_tag {cksum} { - expr {[string index $cksum 0] eq "<" && [string index $cksum end] eq ">"} - } - proc cksum_filter_opts {args} { - set ck_opt_names [dict keys [cksum_default_opts]] - set ck_opts [dict create] - dict for {k v} $args { - if {$k in $ck_opt_names} { - dict set ck_opts $k $v - } - } - return $ck_opts - } - - #convenience so caller doesn't have to pre-calculate the relative path from the base - #Note semantic difference from fill_relativecksums_from_base_and_relativepathdict (hence get_ vs fill_) - #Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will ignore valid-looking prefilled cksum values - #base is the presumed location to store the checksum file. The caller should retain (normalize if relative) - proc get_relativecksum_from_base {base specifiedpath args} { - if {$base ne ""} { - #targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it - #we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix - if {[file pathtype $specifiedpath] eq "relative"} { - if {[file pathtype $base] eq "relative"} { - set normbase [file normalize $base] - set normtarg [file normalize [file join $normbase $specifiedpath]] - set targetpath $normtarg - set storedpath [punk::mix::util::path_relative $normbase $normtarg] - } else { - set targetpath [file join $base $specifiedpath] - set storedpath $specifiedpath - } - } else { - #specifed absolute - if {[file pathtype $base] eq "relative"} { - #relative to cwd or to specifiedpath? For consistency it should arguably be cwd but a case could be made that when one path is relative it is in reference to the other - #there is a strong possibility that allowing this combination will cause confusion - better to disallow - error "get_relativecksum_from_base error: disallowed pathtype combination. Base must be empty or absolute when specified path is absolute" - } - #both absolute - compute relative path if they share a common prefix - set commonprefix [punk::mix::util::path_common_prefix $base $specifiedpath] - if {$commonprefix eq ""} { - #absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base - error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" - } - set targetpath $specifiedpath - set storedpath [punk::mix::util::path_relative $base $specifiedpath] - - } - } else { - if {[file type $specifiedpath] eq "relative"} { - #if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage - set targetpath [file normalize $specifiedpath] - set storedpath $targetpath - } else { - set targetpath $specifiedpath - set storedpath $targetpath - } - } - - # - #NOTE: specifiedpath can be a relative path (to cwd) when base is empty - #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc - #possibly also: base: somewhere targetpath: ../elsewhere/etc - # - #todo - write tests - - - if {([llength $args] % 2) != 0} { - error "get_relativecksum_from_base error. args supplied must be in the form of key-value pairs. received '$args' " - } - if {[dict exists $args cksum]} { - if {[dict get $args cksum] ne "" && ![cksum_is_tag [dict get $args cksum]]} { - error "get_relativecksum_from_base called with existing cksum value (and is not a tag or empty-value to be replaced) cksum: [dict get $args cksum] Set cksum to be empty, any tag such as or remove the key and try again." - } - } - - - set ckopts [cksum_filter_opts {*}$args] - set ckinfo [cksum_path $targetpath {*}$ckopts] - - set keyvals $args - dict set keyvals cksum [dict get $ckinfo cksum] - dict set keyvals cksum_all_opts [dict get $ckinfo opts] - if {[dict exists $ckinfo error]} { - dict set keyvals cksum_error [dict get $ckinfo error] - } - - #set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop - #storedpath is relative if possible - return [dict create $storedpath $keyvals] - } - - #calculate the runtime checksum and vfs checksums - proc get_all_vfs_build_cksums {path} { - set buildfolder [get_build_workdir $path] - set cksum_base_folder [file dirname $buildfolder] ;#this is the /src folder - a reasonable base for our vfs cksums - set dict_cksums [dict create] - - set buildrelpath [punk::repo::path_strip_alreadynormalized_prefixdepth $buildfolder $cksum_base_folder] - set vfs_tail_list [glob -nocomplain -dir $cksum_base_folder -type d -tails *.vfs] - - foreach vfstail $vfs_tail_list { - set vname [file rootname $vfstail] - dict set dict_cksums $vfstail [list cksum ""] - dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] - } - - set fullpath_buildruntime $buildfolder/buildruntime.exe - - set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] - set ck [dict get $ckinfo_buildruntime cksum] - - - set relpath [file join $buildrelpath "buildruntime.exe"] - dict set dict_cksums $relpath [list cksum $ck] - - set dict_cksums [fill_relativecksums_from_base_and_relativepathdict $cksum_base_folder $dict_cksums] - - return $dict_cksums - } - - proc get_vfs_build_cksums_stored {vfsfolder} { - set vfscontainer [file dirname $vfsfolder] - set buildfolder $vfscontainer/_build - set vfs [file tail $vfsfolder] - set vname [file rootname $vfs] - set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] - set ckfile $buildfolder/$vname.cksums - if {[file exists $ckfile]} { - set data [punk::mix::util::fcat -translation binary $ckfile] - foreach ln [split $data \n] { - if {[string trim $ln] eq ""} {continue} - lassign $ln path cksum - dict set dict_vfs $path $cksum - } - } - return $dict_vfs - } - proc get_all_build_cksums_stored {path} { - set buildfolder [get_build_workdir $path] - - set vfscontainer [file dirname $buildfolder] - set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] - set dict_cksums [dict create] - foreach vfs $vfslist { - set vname [file rootname $vfs] - set dict_vfs [get_vfs_build_cksums_stored $vfscontainer/$vfs] - - dict set dict_cksums $vname $dict_vfs - } - return $dict_cksums - } - - proc store_vfs_build_cksums {vfsfolder} { - if {![file isdirectory $vfsfolder]} { - error "Unable to find supplied vfsfolder: $vfsfolder" - } - set vfscontainer [file dirname $vfsfolder] - set buildfolder $vfscontainer/_build - set dict_vfs [get_vfs_build_cksums $vfsfolder] - set data "" - dict for {path cksum} $dict_vfs { - append data "$path $cksum" \n - } - set fd [open $buildfolder/$vname.cksums w] - chan configure $fd -translation binary - puts $fd $data - close $fd - return $dict_vfs - } - - - - } -} +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] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + + uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] + } + proc _cli {args} { + #--------- + #extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + if {![string length $extension]} { + set extension [namespace qualifiers [lindex [info level -1] 0]] + } + #puts stderr "punk::mix::base extension: [string trimleft $extension :]" + if {![string length $extension]} { + #if still no extension - must have been called dirctly as punk::mix::base::_cli + if {![llength $args]} { + set args "help" + } + set extension [namespace current] + } + 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] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + + 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 "_redirected $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 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] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + 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 + #' ``` + #' + #' + + + #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> " opts $opts] + } + if {$ftype ni [list file directory]} { + #review - links? + error "cksum_path error file type '$ftype' not supported" + } + + + set opt_cksum_algorithm [dict get $opts -cksum_algorithm] + if {$opt_cksum_algorithm ni [cksum_algorithms]} { + return [list error unsupported_cksum_algorithm cksum "" opts $opts] + } + set opt_cksum_acls [dict get $opts -cksum_acls] + if {$opt_cksum_acls} { + puts stderr "cksum_path is not yet able to cksum ACLs" + return + } + + set opt_cksum_meta [dict get $opts -cksum_meta] + set opt_use_tar [dict get $opts -cksum_usetar] + if {$ftype eq "file"} { + if {$opt_use_tar eq "auto"} { + if {$opt_cksum_meta eq "1"} { + set opt_use_tar 1 + } else { + #prefer no tar if meta not required - faster/simpler + #meta == auto or 0 + set opt_cksum_meta 0 + set opt_use_tar 0 + } + } elseif {$opt_use_tar eq "0"} { + if {$opt_cksum_meta eq "1"} { + puts stderr "cksum_path doesn't yet support a non-tar cksum with metadata for a file" + return [list error unsupported_meta_without_tar cksum "" opts $opts] + } else { + #meta == auto or 0 + set opt_cksum_meta 0 + } + } else { + #tar == 1 + if {$opt_cksum_meta eq "0"} { + puts stderr "cksum_path doesn't yet support a tar cksum without metadata for a file" + return [list error unsupported_tar_without_meta cksum "" opts $opts] + } else { + #meta == auto or 1 + set opt_cksum_meta 1 + } + } + } elseif {$ftype eq "directory"} { + if {$opt_use_tar eq "auto"} { + if {$opt_cksum_meta in [list "auto" "1"]} { + set opt_use_tar 1 + set opt_cksum_meta 1 + } else { + puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto" + return [list error unsupported_directory_cksum_without_meta cksum "" opts $opts] + } + } elseif {$opt_use_tar eq "0"} { + puts stderr "cksum_path doesn't yet support a cksum of a folder structure without tar. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" + return [list error unsupported_directory_cksum_without_tar cksum "" opts $opts] + } else { + #tar 1 + if {$opt_cksum_meta eq "0"} { + puts stderr "cksum_path doesn't yet support a tar checksum of a folder structure without metadat. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" + return [list error unsupported_without_meta cksum "" opts $opts] + } else { + #meta == auto or 1 + set opt_cksum_meta 1 + } + } + } + + dict set opts_actual -cksum_meta $opt_cksum_meta + dict set opts_actual -cksum_usetar $opt_use_tar + + + if {$opt_use_tar} { + package require tar ;#from tcllib + } + + if {$path eq $base} { + #attempting to cksum at root/volume level of a filesystem.. extra work + #This needs fixing for general use.. not necessarily just for project repos + puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" + return [list error unsupported_path opts $opts] + } + + if {$opt_cksum_algorithm eq "sha1"} { + package require sha1 + set cksum_command [list sha1::sha1 -hex -file] + } elseif {$opt_cksum_algorithm in [list "sha2" "sha256"]} { + package require sha256 + set cksum_command [list sha2::sha256 -hex -file] + } elseif {$opt_cksum_algorithm eq "md5"} { + package require md5 + set cksum_command [list md5::md5 -hex -file] + } elseif {$opt_cksum_algorithm eq "cksum"} { + package require cksum ;#tcllib + set cksum_command [list crc::cksum -format 0x%X -file] + } elseif {$opt_cksum_algorithm eq "adler32"} { + set cksum_command [list cksum_adler32_file] + } elseif {$opt_cksum_algorithm in [list "sha3" "sha3-256"]} { + #todo - replace with something that doesn't call another process + #set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] + set cksum_command [list $sha3_implementation 256] + } elseif {$opt_cksum_algorithm in [list "sha3-224" "sha3-384" "sha3-512"]} { + set bits [lindex [split $opt_cksum_algorithm -] 1] + #set cksum_command [list apply {{bits file} {lindex [exec fossil sha3sum -$bits $file] 0}} $bits] + set cksum_command [list $sha3_implementation $bits] + } + + set cksum "" + if {$opt_use_tar != 0} { + set target [file tail $path] + set tmplocation [punk::mix::util::tmpdir] + set archivename $tmplocation/[punk::mix::util::tmpfile].tar + + cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) + + #temp emission to stdout.. todo - repl telemetry channel + puts stdout "cksum_path: creating temporary tar archive at: $archivename .." + tar::create $archivename $target + if {$ftype eq "file"} { + set sizeinfo "(size [file size $target])" + } else { + set sizeinfo "(file type $ftype - size unknown)" + } + puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." + set cksum [{*}$cksum_command $archivename] + #puts stdout "cksum_path: cleaning up.. " + file delete -force $archivename + cd $startdir + + } else { + #todo + if {$ftype eq "file"} { + if {$opt_cksum_meta} { + return [list error unsupported_opts_combo cksum "" opts $opts] + } else { + set cksum [{*}$cksum_command $path] + } + } else { + error "cksum_path unsupported $opts for path type [file type $path]" + } + } + set result [dict create] + dict set result cksum $cksum + dict set result opts $opts_actual + return $result + } + + #dict_path_cksum keyed on path - with value as a dict that must contain cksum key - but can contain other keys + #e.g -cksum_usetar which is one of the keys understood by the punk::mix::base::lib::cksum_path function - or unrelated keys which will also be passed through + #cksum only calculated for keys in dict where cksum is empty - ie return same dict but with empty cksums filled out. + #base can be empty string in which case paths must be absolute + proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { + if {$base eq ""} { + set error_paths [list] + dict for {path pathinfo} $dict_path_cksum { + if {[file pathtype $path] ne "absolute"} { + lappend error_paths $path + } + } + if {[llength $error_paths]} { + puts stderr "get_relativecksums_from_base_and_relativepathdict has empty base - and non-absolute paths in the supplied checksum dict - aborting" + puts stderr "error_paths: $error_paths" + error "fill_relativecksums_from_base_and_relativepathdict error: non-absolute paths when base empty. $error_paths" + } + } else { + if {[file pathtype $base] ne "absolute"} { + error "fill_relativecksums_from_base_and_relativepathdict error: base supplied but was not absolute path. $base" + } + #conversely now we have a base - so we require all paths are relative. + #We will ignore/disallow volume-relative - as these shouldn't be used here either + set error_paths [list] + dict for {path pathinfo} $dict_path_cksum { + if {[file pathtype $path] ne "relative"} { + lappend error_paths $path + } + } + if {[llength $error_paths]} { + puts stderr "fill_relativecksums_from_base_and_relativepathdict has a supplied absolute base path, but some of the paths in the supplied dict are not relative - aborting" + error "fill_relativecksums_from_base_and_relativepathdict error: non-relative paths when base supplied. $error_paths" + } + } + + + dict for {path pathinfo} $dict_path_cksum { + if {![dict exists $pathinfo cksum]} { + dict set pathinfo cksum "" + } else { + if {[dict get $pathinfo cksum] ne "" && ![cksum_is_tag [dict get $pathinfo cksum]]} { + continue ;#already filled with non-tag value + } + } + if {$base ne ""} { + set fullpath [file join $base $path] + } else { + set fullpath $path + } + + set ckopts [cksum_filter_opts {*}$pathinfo] + + if {![file exists $fullpath]} { + dict set dict_path_cksum $path cksum "" + } else { + set ckinfo [cksum_path $fullpath {*}$ckopts] + dict set dict_path_cksum $path cksum [dict get $ckinfo cksum] + dict set dict_path_cksum $path cksum_all_opts [dict get $ckinfo opts] + if {[dict exists $ckinfo error]} { + dict set dict_path_cksum $path cksum_error [dict get $ckinfo error] + } + } + } + + return $dict_path_cksum + } + #whether cksum is e.g + proc cksum_is_tag {cksum} { + expr {[string index $cksum 0] eq "<" && [string index $cksum end] eq ">"} + } + proc cksum_filter_opts {args} { + set ck_opt_names [dict keys [cksum_default_opts]] + set ck_opts [dict create] + dict for {k v} $args { + if {$k in $ck_opt_names} { + dict set ck_opts $k $v + } + } + return $ck_opts + } + + #convenience so caller doesn't have to pre-calculate the relative path from the base + #Note semantic difference from fill_relativecksums_from_base_and_relativepathdict (hence get_ vs fill_) + #Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will ignore valid-looking prefilled cksum values + #base is the presumed location to store the checksum file. The caller should retain (normalize if relative) + proc get_relativecksum_from_base {base specifiedpath args} { + if {$base ne ""} { + #targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it + #we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix + if {[file pathtype $specifiedpath] eq "relative"} { + if {[file pathtype $base] eq "relative"} { + set normbase [file normalize $base] + set normtarg [file normalize [file join $normbase $specifiedpath]] + set targetpath $normtarg + set storedpath [punk::mix::util::path_relative $normbase $normtarg] + } else { + set targetpath [file join $base $specifiedpath] + set storedpath $specifiedpath + } + } else { + #specifed absolute + if {[file pathtype $base] eq "relative"} { + #relative to cwd or to specifiedpath? For consistency it should arguably be cwd but a case could be made that when one path is relative it is in reference to the other + #there is a strong possibility that allowing this combination will cause confusion - better to disallow + error "get_relativecksum_from_base error: disallowed pathtype combination. Base must be empty or absolute when specified path is absolute" + } + #both absolute - compute relative path if they share a common prefix + set commonprefix [punk::mix::util::path_common_prefix $base $specifiedpath] + if {$commonprefix eq ""} { + #absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base + error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" + } + set targetpath $specifiedpath + set storedpath [punk::mix::util::path_relative $base $specifiedpath] + + } + } else { + if {[file type $specifiedpath] eq "relative"} { + #if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage + set targetpath [file normalize $specifiedpath] + set storedpath $targetpath + } else { + set targetpath $specifiedpath + set storedpath $targetpath + } + } + + # + #NOTE: specifiedpath can be a relative path (to cwd) when base is empty + #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc + #possibly also: base: somewhere targetpath: ../elsewhere/etc + # + #todo - write tests + + + if {([llength $args] % 2) != 0} { + error "get_relativecksum_from_base error. args supplied must be in the form of key-value pairs. received '$args' " + } + if {[dict exists $args cksum]} { + if {[dict get $args cksum] ne "" && ![cksum_is_tag [dict get $args cksum]]} { + error "get_relativecksum_from_base called with existing cksum value (and is not a tag or empty-value to be replaced) cksum: [dict get $args cksum] Set cksum to be empty, any tag such as or remove the key and try again." + } + } + + + set ckopts [cksum_filter_opts {*}$args] + set ckinfo [cksum_path $targetpath {*}$ckopts] + + set keyvals $args + dict set keyvals cksum [dict get $ckinfo cksum] + dict set keyvals cksum_all_opts [dict get $ckinfo opts] + if {[dict exists $ckinfo error]} { + dict set keyvals cksum_error [dict get $ckinfo error] + } + + #set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop + #storedpath is relative if possible + return [dict create $storedpath $keyvals] + } + + #calculate the runtime checksum and vfs checksums + proc get_all_vfs_build_cksums {path} { + set buildfolder [get_build_workdir $path] + set cksum_base_folder [file dirname $buildfolder] ;#this is the /src folder - a reasonable base for our vfs cksums + set dict_cksums [dict create] + + set buildrelpath [punk::repo::path_strip_alreadynormalized_prefixdepth $buildfolder $cksum_base_folder] + set vfs_tail_list [glob -nocomplain -dir $cksum_base_folder -type d -tails *.vfs] + + foreach vfstail $vfs_tail_list { + set vname [file rootname $vfstail] + dict set dict_cksums $vfstail [list cksum ""] + dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] + } + + set fullpath_buildruntime $buildfolder/buildruntime.exe + + set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] + set ck [dict get $ckinfo_buildruntime cksum] + + + set relpath [file join $buildrelpath "buildruntime.exe"] + dict set dict_cksums $relpath [list cksum $ck] + + set dict_cksums [fill_relativecksums_from_base_and_relativepathdict $cksum_base_folder $dict_cksums] + + return $dict_cksums + } + + proc get_vfs_build_cksums_stored {vfsfolder} { + set vfscontainer [file dirname $vfsfolder] + set buildfolder $vfscontainer/_build + set vfs [file tail $vfsfolder] + set vname [file rootname $vfs] + set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] + set ckfile $buildfolder/$vname.cksums + if {[file exists $ckfile]} { + set data [punk::mix::util::fcat -translation binary $ckfile] + foreach ln [split $data \n] { + if {[string trim $ln] eq ""} {continue} + lassign $ln path cksum + dict set dict_vfs $path $cksum + } + } + return $dict_vfs + } + proc get_all_build_cksums_stored {path} { + set buildfolder [get_build_workdir $path] + + set vfscontainer [file dirname $buildfolder] + set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] + set dict_cksums [dict create] + foreach vfs $vfslist { + set vname [file rootname $vfs] + set dict_vfs [get_vfs_build_cksums_stored $vfscontainer/$vfs] + + dict set dict_cksums $vname $dict_vfs + } + return $dict_cksums + } + + proc store_vfs_build_cksums {vfsfolder} { + if {![file isdirectory $vfsfolder]} { + error "Unable to find supplied vfsfolder: $vfsfolder" + } + set vfscontainer [file dirname $vfsfolder] + set buildfolder $vfscontainer/_build + set dict_vfs [get_vfs_build_cksums $vfsfolder] + set data "" + dict for {path cksum} $dict_vfs { + append data "$path $cksum" \n + } + set fd [open $buildfolder/$vname.cksums w] + chan configure $fd -translation binary + puts $fd $data + close $fd + return $dict_vfs + } + + + + } +} diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm index 1ca4cc14..62e366c1 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm @@ -73,7 +73,7 @@ namespace eval punk::mix::commandset::layout { set glob * } set layouts [list] - #set tplfolderdict [punk::cap::templates::folders] + #set tplfolderdict [punk::cap::call_handler punk.templates folders] set tplfolderdict [punk::mix::base::lib::get_template_basefolders] dict for {tdir folderinfo} $tplfolderdict { set layout_base $tdir/layouts diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index d7150abc..06cddf45 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -305,7 +305,7 @@ namespace eval punk::mix::commandset::project { #todo - tag substitutions in src/doc tree - cd $projectdir + ::cd $projectdir if {[file exists $projectdir/src/modules]} { foreach m $opt_modules { @@ -323,7 +323,7 @@ namespace eval punk::mix::commandset::project { #generate www/man/md output in 'embedded' folder which should be checked into repo for online documentation if {[file exists $projectdir/src]} { - cd $projectdir/src + ::cd $projectdir/src #---------- set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] $installer set_source_target $projectdir/src/doc $projectdir/src/embedded @@ -357,7 +357,7 @@ namespace eval punk::mix::commandset::project { $installer destroy } - cd $projectdir + ::cd $projectdir if {![punk::repo::is_fossil_root $projectdir]} { set first_fossil 1 @@ -742,7 +742,7 @@ namespace eval punk::mix::commandset::project { set workingdir [lindex $workdirs 0] puts stdout "1 result. Changing dir to $workingdir" if {[file exists $workingdir]} { - cd $workingdir + ::cd $workingdir return $workingdir } else { puts stderr "path $workingdir doesn't appear to exist" @@ -753,7 +753,7 @@ namespace eval punk::mix::commandset::project { if {[string trim $answer] in $col_rowids} { set index [expr {$answer - 1}] set workingdir [lindex $workdirs $index] - cd $workingdir + ::cd $workingdir puts stdout [pmix stat] return $workingdir } diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/templates-0.1.0.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/templates-0.1.0.tm index d4847541..8d525177 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/templates-0.1.0.tm +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/templates-0.1.0.tm @@ -23,10 +23,43 @@ package require punk::cap # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::mix::templates { + variable pkg punk::mix::templates + variable cap_provider + punk::cap::register_package punk::mix::templates [list\ - {templates {relpath ../templates}}\ + {punk.templates {relpath ../templates}}\ ] - + namespace eval capsystem { + if {[info commands capprovider.registration] eq ""} { + punk::cap::interface_capprovider.registration create capprovider.registration + oo::objdefine capprovider.registration { + method get_declarations {} { + set decls [list] + lappend decls punk.templates {relpath ../templates} + lappend decls punk.templates {relpath ../templates2} + return $decls + } + } + } + } + + if {[info commands provider] eq ""} { + punk::cap::interface_capprovider.provider create provider + oo::objdefine provider { + method register {{capabilityname_glob *}} { + #puts registering punk::mix::templates $capabilityname + next + } + method capabilities {} { + next + } + } + } + + # -- --- + #provider api + # -- --- + #none - declarations only } diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/overlay-0.1.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/overlay-0.1.tm index 9ee458bf..23e69344 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/overlay-0.1.tm +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/overlay-0.1.tm @@ -1,158 +1,158 @@ - - -package require punk::mix::util - -namespace eval ::punk::overlay { - #based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend - # extend an ensemble-like routine with the routines in some namespace - # - # e.g custom_from_base ::punk::mix::cli ::punk::mix::base - # - proc custom_from_base {routine base} { - if {![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 - ] - ] - - punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util - #namespace eval ${routine}::util { - #namespace import ::punk::mix::util::* - #} - punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib - #namespace eval ${routine}::lib [string map [list $base] { - # namespace import ::lib::* - #}] - - namespace eval ${routine}::lib [string map [list $base $routine] { - if {[namespace exists ::lib]} { - set current_paths [namespace path] - if {"" ni $current_paths} { - lappend current_paths - } - namespace path $current_paths - } - }] - - 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 - } - #load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix - #Note: commandset may be imported by different CLIs with different bases *at the same time* - #so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) - #we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. - #commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they - #want the convenience of using lib:xxx with commands coming from those packages. - #This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. - #The basic principle is that the commandset is loaded into the caller(s) with a prefix - #- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) - proc import_commandset {prefix separator cmdnamespace} { - set bad_seps [list "::"] - if {$separator in $bad_seps} { - error "import_commandset invalid separator '$separator'" - } - #namespace may or may not be a package - # allow with or without leading :: - if {[string range $cmdnamespace 0 1] eq "::"} { - set cmdpackage [string range $cmdnamespace 2 end] - } else { - set cmdpackage $cmdnamespace - set cmdnamespace ::$cmdnamespace - } - - if {![namespace exists $cmdnamespace]} { - #only do package require if the namespace not already present - catch {package require $cmdpackage} pkg_load_info - #recheck - if {![namespace exists $cmdnamespace]} { - set prov [package provide $cmdpackage] - if {[string length $prov]} { - set provinfo "(package $cmdpackage is present with version $prov)" - } else { - set provinfo "(package $cmdpackage not present)" - } - error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" - } - } - - punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util - - #let child namespace 'lib' resolve parent namespace and thus util::xxx - namespace eval ${cmdnamespace}::lib [string map [list $cmdnamespace] { - set nspaths [namespace path] - if {"" ni $nspaths} { - lappend nspaths - } - namespace path $nspaths - }] - - set imported_commands [list] - set nscaller [uplevel 1 [list namespace current]] - if {[catch { - namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] - foreach cmd [info commands ${nscaller}::temp_import::*] { - set cmdtail [namespace tail $cmd] - if {$cmdtail eq "_default"} { - set import_as ${nscaller}::${prefix} - } else { - set import_as ${nscaller}::${prefix}${separator}${cmdtail} - } - rename $cmd $import_as - lappend imported_commands $import_as - } - } errM]} { - puts stderr "Error loading commandset $prefix $separator $cmdnamespace" - puts stderr "err: $errM" - } - return $imported_commands - } -} - - -package provide punk::overlay [namespace eval punk::overlay { - variable version - set version 0.1 -}] + + +package require punk::mix::util + +namespace eval ::punk::overlay { + #based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend + # extend an ensemble-like routine with the routines in some namespace + # + # e.g custom_from_base ::punk::mix::cli ::punk::mix::base + # + proc custom_from_base {routine base} { + if {![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 + ] + ] + + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util + #namespace eval ${routine}::util { + #namespace import ::punk::mix::util::* + #} + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib + #namespace eval ${routine}::lib [string map [list $base] { + # namespace import ::lib::* + #}] + + namespace eval ${routine}::lib [string map [list $base $routine] { + if {[namespace exists ::lib]} { + set current_paths [namespace path] + if {"" ni $current_paths} { + lappend current_paths + } + namespace path $current_paths + } + }] + + 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 + } + #load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix + #Note: commandset may be imported by different CLIs with different bases *at the same time* + #so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) + #we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. + #commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they + #want the convenience of using lib:xxx with commands coming from those packages. + #This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. + #The basic principle is that the commandset is loaded into the caller(s) with a prefix + #- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) + proc import_commandset {prefix separator cmdnamespace} { + set bad_seps [list "::"] + if {$separator in $bad_seps} { + error "import_commandset invalid separator '$separator'" + } + #namespace may or may not be a package + # allow with or without leading :: + if {[string range $cmdnamespace 0 1] eq "::"} { + set cmdpackage [string range $cmdnamespace 2 end] + } else { + set cmdpackage $cmdnamespace + set cmdnamespace ::$cmdnamespace + } + + if {![namespace exists $cmdnamespace]} { + #only do package require if the namespace not already present + catch {package require $cmdpackage} pkg_load_info + #recheck + if {![namespace exists $cmdnamespace]} { + set prov [package provide $cmdpackage] + if {[string length $prov]} { + set provinfo "(package $cmdpackage is present with version $prov)" + } else { + set provinfo "(package $cmdpackage not present)" + } + error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" + } + } + + punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util + + #let child namespace 'lib' resolve parent namespace and thus util::xxx + namespace eval ${cmdnamespace}::lib [string map [list $cmdnamespace] { + set nspaths [namespace path] + if {"" ni $nspaths} { + lappend nspaths + } + namespace path $nspaths + }] + + set imported_commands [list] + set nscaller [uplevel 1 [list namespace current]] + if {[catch { + namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] + foreach cmd [info commands ${nscaller}::temp_import::*] { + set cmdtail [namespace tail $cmd] + if {$cmdtail eq "_default"} { + set import_as ${nscaller}::${prefix} + } else { + set import_as ${nscaller}::${prefix}${separator}${cmdtail} + } + rename $cmd $import_as + lappend imported_commands $import_as + } + } errM]} { + puts stderr "Error loading commandset $prefix $separator $cmdnamespace" + puts stderr "err: $errM" + } + return $imported_commands + } +} + + +package provide punk::overlay [namespace eval punk::overlay { + variable version + set version 0.1 +}] diff --git a/src/modules/punk/mix/templates/layouts/project/src/make.tcl b/src/modules/punk/mix/templates/layouts/project/src/make.tcl index e942ebe7..ce8124f9 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/make.tcl +++ b/src/modules/punk/mix/templates/layouts/project/src/make.tcl @@ -259,84 +259,110 @@ if {$::punkmake::command eq "bootsupport"} { proc bootsupport_localupdate {projectroot} { set bootsupport_modules [list] + set bootsupport_module_folders [list] set bootsupport_config $projectroot/src/bootsupport/include_modules.config ;# if {[file exists $bootsupport_config]} { + set targetroot $projectroot/src/bootsupport/modules source $bootsupport_config ;#populate $bootsupport_modules with project-specific list if {![llength $bootsupport_modules]} { puts stderr "No local bootsupport modules configured for updating" - return - } - set targetroot $projectroot/src/bootsupport/modules - - if {[catch { - #---------- - set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] - $boot_installer set_source_target $projectroot $projectroot/src/bootsupport - set boot_event [$boot_installer start_event {-make_step bootsupport}] - #---------- - } errM]} { - puts stderr "Unable to use punkcheck for bootsupport error: $errM" - set boot_event "" - } + } else { - foreach {relpath module} $bootsupport_modules { - set module [string trim $module :] - set module_subpath [string map [list :: /] [namespace qualifiers $module]] - set srclocation [file join $projectroot $relpath $module_subpath] - #puts stdout "$relpath $module $module_subpath $srclocation" - set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] - #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 - if {![llength $pkgmatches]} { - puts stderr "Missing source for bootsupport module $module - not found in $srclocation" - continue - } - set latestfile [lindex $pkgmatches 0] - set latestver [lindex [split [file rootname $latestfile] -] 1] - foreach m $pkgmatches { - lassign [split [file rootname $m] -] _pkg ver - #puts "comparing $ver vs $latestver" - if {[package vcompare $ver $latestver] == 1} { - set latestver $ver - set latestfile $m - } - } - set srcfile [file join $srclocation $latestfile] - set tgtfile [file join $targetroot $module_subpath $latestfile] - if {$boot_event ne ""} { + if {[catch { #---------- - $boot_event targetset_init INSTALL $tgtfile - $boot_event targetset_addsource $srcfile + set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] + $boot_installer set_source_target $projectroot $projectroot/src/bootsupport + set boot_event [$boot_installer start_event {-make_step bootsupport}] #---------- - if {\ - [llength [dict get [$boot_event targetset_source_changes] changed]]\ - || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ - } { - file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists - $boot_event targetset_started - # -- --- --- --- --- --- - puts "BOOTSUPPORT update: $srcfile -> $tgtfile" - if {[catch { - file copy -force $srcfile $tgtfile - } errM]} { - $boot_event targetset_end FAILED + } errM]} { + puts stderr "Unable to use punkcheck for bootsupport error: $errM" + set boot_event "" + } + + foreach {relpath module} $bootsupport_modules { + set module [string trim $module :] + set module_subpath [string map [list :: /] [namespace qualifiers $module]] + set srclocation [file join $projectroot $relpath $module_subpath] + #puts stdout "$relpath $module $module_subpath $srclocation" + set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] + #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 + if {![llength $pkgmatches]} { + puts stderr "Missing source for bootsupport module $module - not found in $srclocation" + continue + } + set latestfile [lindex $pkgmatches 0] + set latestver [lindex [split [file rootname $latestfile] -] 1] + foreach m $pkgmatches { + lassign [split [file rootname $m] -] _pkg ver + #puts "comparing $ver vs $latestver" + if {[package vcompare $ver $latestver] == 1} { + set latestver $ver + set latestfile $m + } + } + set srcfile [file join $srclocation $latestfile] + set tgtfile [file join $targetroot $module_subpath $latestfile] + if {$boot_event ne ""} { + #---------- + $boot_event targetset_init INSTALL $tgtfile + $boot_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$boot_event targetset_source_changes] changed]]\ + || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ + } { + file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists + $boot_event targetset_started + # -- --- --- --- --- --- + puts "BOOTSUPPORT update: $srcfile -> $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $boot_event targetset_end FAILED + } else { + $boot_event targetset_end OK + } + # -- --- --- --- --- --- } else { - $boot_event targetset_end OK + puts -nonewline stderr "." + $boot_event targetset_end SKIPPED } - # -- --- --- --- --- --- + $boot_event end } else { - puts -nonewline stderr "." - $boot_event targetset_end SKIPPED + file copy -force $srcfile $tgtfile } - $boot_event end - } else { - file copy -force $srcfile $tgtfile + } + if {$boot_event ne ""} { + puts \n + $boot_event destroy + $boot_installer destroy } } - if {$boot_event ne ""} { - puts \n - $boot_event destroy - $boot_installer destroy + + foreach folder $bootsupport_module_folders { + #explicitly ignore punk/mix/templates folder even if specified in config. + #punk/mix/templates contains modules including punk/mix/templates itself - the actual templates aren't needed for the bootsupport system, + # as make.tcl shouldn't be building new projects from the one being made. + #review. + #should we be autodetecting such recursive folder structures - (or is the bootsupport copying in need of a rethink?) + if {[string trim $folder /] eq "punk/mix/templates"} { + puts stderr "IGNORING punk/mix/templates - not needed/desirable in bootsupport" + continue + } + set src [file join $projectroot/modules $folder] + if {![file isdirectory $src]} { + puts stderr "bootsupport folder not found: $src" + continue + } + set tgt [file join $targetroot $folder] + file mkdir $tgt + + puts stdout "BOOTSUPPORT non_tm_files $src - copying to $tgt (if source file changed)" + set overwrite "installedsourcechanged-targets" + set resultdict [punkcheck::install_non_tm_files $src $tgt -installer make.tcl -overwrite $overwrite -punkcheck_folder $projectroot/src/bootsupport] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] } + } }