You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
528 lines
23 KiB
528 lines
23 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2023 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::cap 0.1.0 |
|
# Meta platform tcl |
|
# Meta description pkg capability register |
|
# Meta license BSD |
|
# @@ Meta End |
|
|
|
|
|
#*** !doctools |
|
#[manpage_begin punk::cap 0 0.1.0] |
|
#[copyright "2023 JMNoble - BSD licensed"] |
|
#[titledesc {Module API}] |
|
#[moddesc {punk capabilities plugin system}] |
|
#[require punk::cap] |
|
#[description] |
|
#[list_begin definitions] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
##e.g package require frobz |
|
package require oolib |
|
|
|
|
|
|
|
# mkdoc markdown |
|
#' --- |
|
#' author: JMNoble |
|
#' --- |
|
#' ## 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 <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 pkgcapsdeclared [dict create] |
|
variable pkgcapsaccepted [dict create] |
|
variable caps [dict create] |
|
|
|
namespace eval class { |
|
if {[info commands [namespace current]::interface_caphandler.registry] eq ""} { |
|
#Handler classes |
|
oo::class create [namespace current]::interface_caphandler.registry { |
|
method pkg_register {pkg capname capdict fullcapabilitylist} { |
|
#*** |
|
#[call [class interface_caphandler.registry] [method pkg_register] [arg pkg] [arg capname] [arg capdict] [arg 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} { |
|
#*** |
|
#[call [class interface_caphandler.registry] [method pkg_unregister] [arg pkg]] |
|
return ;#unregistration return is ignored - review |
|
} |
|
} |
|
oo::class create [namespace current]::interface_caphandler.sysapi { |
|
|
|
} |
|
|
|
|
|
#Provider classes |
|
oo::class create [namespace current]::interface_capprovider.registration { |
|
method get_declarations {} { |
|
#*** |
|
#[call [class interface_capprovider.registration] [method pkg_unregister] [arg pkg]] |
|
error "interface_capprovider.registration not implemented by provider" |
|
} |
|
} |
|
oo::class create [namespace current]::interface_capprovider.provider { |
|
variable provider_pkg |
|
variable registrationobj |
|
constructor {providerpkg} { |
|
variable provider_pkg |
|
if {$providerpkg in [list "" "::"]} { |
|
error "interface_capprovider.provider constructor error. Invalid provider '$providerpkg'" |
|
} |
|
if {![namespace exists ::$providerpkg]} { |
|
error "interface_capprovider.provider constructor error. Invalid provider '$providerpkg' - matching namespace not found" |
|
} |
|
|
|
set registrationobj ::${providerpkg}::capsystem::capprovider.registration |
|
if {[info commands $registrationobj] eq ""} { |
|
error "capprovider.provider constructor error. Missing capprovider.registration interface at '$obj' (command not found) interface_capprovider.regstration instantiation must precede interface_capprovider.provider" |
|
} |
|
|
|
set provider_pkg [string trim $providerpkg ""] |
|
|
|
} |
|
method register {{capabilityname_glob *}} { |
|
#*** |
|
#[call [class interface_capprovider.provider] [method register] [opt capabilityname_glob]] |
|
variable provider_pkg |
|
set all_decls [$registrationobj get_declarations] |
|
set register_decls [lsearch -all -inline -index 0 $all_decls $capabilityname_glob] |
|
punk::cap::register_package $provider_pkg $register_decls |
|
} |
|
method capabilities {} { |
|
#*** |
|
#[call [class interface_capprovider.provider] [method capabilities]] |
|
variable provider_pkg |
|
variable registrationobj |
|
|
|
set capabilities [list] |
|
set decls [$registrationobj get_declarations] |
|
foreach decl $decls { |
|
lassign $decl capname capdict |
|
if {$capname ni $capabilities} { |
|
lappend capabilities $capname |
|
} |
|
} |
|
return $capname |
|
} |
|
} |
|
} |
|
} ;# end namespace class |
|
namespace eval capsystem { |
|
proc get_caphandler_registry {capname} { |
|
set ns [::punk::cap::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 "" |
|
} |
|
} |
|
|
|
|
|
#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 [punk::cap::capsystem::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} { |
|
#*** !doctools |
|
# [call [fun exists] [arg capname]] |
|
# Return a boolean indicating if the named capability exists (0|1) |
|
|
|
# mkdoc markdown |
|
#' |
|
#' ## **exists(capname)** |
|
#' |
|
#' > return a boolean indicating the existence of a capability |
|
#' |
|
#' > Arguments: |
|
#' |
|
#' > - *capname* - string indicating the name of the capability |
|
#' |
|
#' > Returns: 0|1 |
|
#' |
|
variable caps |
|
return [dict exists $caps $capname] |
|
} |
|
proc has_handler {capname} { |
|
#*** !doctools |
|
# [call [fun has_handler] [arg capname]] |
|
# Return a boolean indicating if the named capability has a handler package installed (0|1) |
|
|
|
|
|
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}::api_$capname |
|
$obj [lindex $args 0] {*}[lrange $args 1 end] |
|
} |
|
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 pkgcapsdeclared |
|
variable pkgcapsaccepted |
|
variable caps |
|
if {[string match ::* $pkg]} { |
|
set pkg [string range $pkg 2 end] |
|
} |
|
if {[dict exists $pkgcapsaccepted $pkg]} { |
|
set pkg_already_accepted [dict get $pkgcapsaccepted $pkg] |
|
} else { |
|
set pkg_already_accepted [list] |
|
} |
|
#for each capability |
|
# - ensure 1st element is a single word |
|
# - ensure that if 2nd element (capdict) is present - it is dict shaped |
|
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:'$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: '$capspec'" |
|
} |
|
if {$capspec in $pkg_already_accepted} { |
|
#review - multiple handlers? if so - will need to record which handler(s) accepted the capspec |
|
puts stderr "register_package pkg $pkg already has capspec marked as accepted: $capspec" |
|
continue |
|
} |
|
if {[dict exists $caps $capname]} { |
|
set cap_pkgs [dict get $caps $capname providers] |
|
} else { |
|
dict set caps $capname [dict create handler "" providers [list]] |
|
set cap_pkgs [list] |
|
} |
|
#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 [punk::cap::capsystem::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 |
|
} |
|
} |
|
#another call to register_pkg with same pkg may have been made (most likely with different capname) so we must append - but check not already present |
|
#dict lappend pkgcapsdeclared $pkg $capabilitylist |
|
if {[dict exists $pkgcapsdeclared $pkg]} { |
|
set capspecs [dict get $pkgcapsdeclared $pkg] |
|
foreach spec $capspecs { |
|
if {$spec ni $capspecs} { |
|
lappend capspecs $spec |
|
} |
|
} |
|
dict set pkgcapsdeclared $pkg $capspecs |
|
} else { |
|
dict set pkgcapsdeclared $pkg $capabilitylist |
|
} |
|
} |
|
|
|
#todo! |
|
proc unregister_package {pkg {capname *}} { |
|
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 [punk::cap::capsystem::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 dataset deregistration required this should probably be a separate thing |
|
$capreg pkg_unregister $pkg $capname |
|
} |
|
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 <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 pkgcapsdeclared |
|
variable caps |
|
if {[string match ::* $pkg]} { |
|
set pkg [string range $pkg 2 end] |
|
} |
|
if {![dict exists $pkgcapsdeclared $pkg]} { |
|
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
|
} |
|
if {[dict size $pkgcapsdeclared] > 1} { |
|
set pkginfo [dict get $pkgcapsdeclared $pkg] |
|
#remove and re-add at end of dict |
|
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 providers $cap_pkgs |
|
} |
|
} |
|
} |
|
} |
|
} |
|
proc demote_package {pkg} { |
|
variable pkgcapsdeclared |
|
variable caps |
|
if {[string match ::* $pkg]} { |
|
set pkg [string range $pkg 2 end] |
|
} |
|
if {![dict exists $pkgcapsdeclared $pkg]} { |
|
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
|
} |
|
if {[dict size $pkgcapsdeclared] > 1} { |
|
set pkginfo [dict get $pkgcapsdeclared $pkg] |
|
#remove and re-add at start of dict |
|
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 providers $cap_pkgs |
|
} |
|
} |
|
} |
|
} |
|
} |
|
proc pkgcap {pkg} { |
|
variable pkgcapsdeclared |
|
variable pkgcapsaccepted |
|
if {[string match ::* $pkg]} { |
|
set pkg [string range $pkg 2 end] |
|
} |
|
if {[dict exists $pkgcapsdeclared $pkg]} { |
|
set accepted "" |
|
if {[dict exists $pkgcapsaccepted $pkg]} { |
|
set accepted [dict get $pkgcapsaccepted $pkg] |
|
} |
|
return [dict create declared [dict get $pkgcapsdeclared $pkg] accepted $accepted] |
|
} else { |
|
return |
|
} |
|
} |
|
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 capnames [lsort [dict keys $caps $glob]] |
|
set cap_list [list] |
|
foreach capname $capnames { |
|
lappend cap_list [list $capname [dict get $caps $capname]] |
|
} |
|
return $cap_list |
|
} |
|
|
|
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 $cap_list |
|
} |
|
|
|
} |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::cap [namespace eval punk::cap { |
|
variable version |
|
variable pkg punk::cap |
|
set version 0.1.0 |
|
variable README.md [string map [list %pkg% $pkg %ver% $version] { |
|
# punk capabilities system |
|
## pkg: %pkg% version: %ver% |
|
|
|
punk::cap base namespace |
|
}] |
|
return $version |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[list_end] |
|
#[manpage_end]
|
|
|