# 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 <capname> <capnamespace>
# capability provider - a package which registers as providing one or more capablities.
# registered using register_package <pkg> <capabilitylist>
# 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]::callbackbase] eq ""} {
#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
}
}
}
#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.
#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 cb [get_handler_callback $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 [$cb 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 get_handler {capname} {
variable caps
if {[dict exists $caps $capname]} {
return [dict get $caps $capname handler]
}
return ""
}
proc get_handler_callback {capname} {
set ns [get_handler $capname]
if {[namespace exists $ns]} {
if {[info exists ${ns}::callback]} {
if {[info object isa object ${ns}::callback]} {
return ${ns}::callback
}
}
}
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 +158,194 @@ 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 cap handler - call it's init/validation callback for the pkg
set do_register 1 ;#default assumption unless vetoed by handler
if {[set cb [get_handler_callback $capname]] ne ""} {
#Note that callback must be able to handle multiple calls for same pkg
set do_register [$cb pkg_register $pkg $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 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 cb [get_handler_callback $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?)
$cb pkg_unregister $pkg
}
set pkglist [lreplace $pkglist $posn $posn]
dict set caps $capname providers $pkglist
}
}
#delete the main registration record
dict unset pkgcapsdeclared $pkg
}
dict set pkgcap $pkg $capabilitylist
}
#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 <capname>
#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 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
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} {
set pkgs [dict get [lindex $templates_record 1] providers]
set folderdict [dict create]
foreach pkg $pkgs {
set provide_statement [package ifneeded $pkg [package require $pkg]]
set tmfile [lindex $provide_statement end]
if {![file exists $tmfile]} {
puts stderr "punk::cap::templates::folders WARNING - unable to determine base folder for package '$pkg' which is registered with punk::cap as a provider of 'templates' capability"
continue
}
set caplist [dict get [punk::cap::pkgcap $pkg] accepted]
set templates_entries [lsearch -all -inline -index 0 $caplist templates] ;#we generally expect only one - but if multiple exist - use them
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 relpath location [dict get $templates_dict relpath] for package '$pkg' which is registered with punk::cap as a provider of 'templates' capability"
}
} else {
puts stderr "punk::cap::templates::folders WARNING - registered pkg '$pkg' has capability 'templates' but has an entry with no 'relpath' key - unable to use as source of templates"
}
}
}
return $folderdict
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::cap::templates [namespace eval punk::cap::templates {
