# -*- 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 999999.0a1.0 # Meta platform tcl # Meta description pkg capability register # Meta license BSD # @@ Meta End #*** !doctools #[manpage_begin punkshell_module_punk::cap 0 999999.0a1.0] #[copyright "2023 JMNoble - BSD licensed"] #[titledesc {capability provider and handler plugin system}] #[moddesc {punk capabilities plugin system}] #[require punk::cap] #[description] #[keywords module capability plugin] #[section Overview] #[para]punk::cap provides management of named capabilities and the provider packages and handler packages that implement a pluggable capability. #[para]see also [uri https://core.tcl-lang.org/tcllib/doc/trunk/embedded/md/tcllib/files/modules/pluginmgr/pluginmgr.md {tcllib pluginmgr}] for an alternative which uses safe interpreters #[subsection Concepts] #[para]A [term capability] may be something like providing a folder of files, or just a data dictionary, and/or an API # #[para][term {capability handler}] - a package/namespace which may provide validation and standardised ways of looking up provider data # registered (or not) using register_capabilityname # #[para][term {capability provider}] - a package which registers as providing one or more capablities. #[para]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. #*** !doctools #[section API] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements ##e.g package require frobz package require oolib # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::cap { variable pkgcapsdeclared [tcl::dict::create] variable pkgcapsaccepted [tcl::dict::create] variable caps [tcl::dict::create] namespace eval class { if {[tcl::info::commands ::punk::cap::class::interface_caphandler.registry] eq ""} { #*** !doctools #[subsection {Namespace punk::cap::class}] #[para] class definitions #[list_begin itemized] [comment {- punk::cap::class groupings -}] # [item] # [para] [emph {handler_classes}] # [list_begin enumerated] oo::class create ::punk::cap::class::interface_caphandler.registry { #*** !doctools #[enum] CLASS [class interface_caphandler.registry] #[list_begin definitions] # [para] [emph METHODS] method pkg_register {pkg capname capdict fullcapabilitylist} { #*** !doctools #[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} { #*** !doctools #[call class::interface_caphandler.registry [method pkg_unregister] [arg pkg]] return ;#unregistration return is ignored - review } #*** !doctools #[list_end] } oo::class create ::punk::cap::class::interface_caphandler.sysapi { #*** !doctools #[enum] CLASS [class interface_caphandler.sysapi] #[list_begin definitions] # [para] [emph METHODS] #*** !doctools #[list_end] } #*** !doctools # [list_end] [comment {- end enumeration handler classes -}] #*** !doctools # [item] # [para] [emph {provider_classes}] # [list_begin enumerated] #Provider classes oo::class create ::punk::cap::class::interface_capprovider.registration { #*** !doctools # [enum] CLASS [class interface_cappprovider.registration] # [para]Your provider package will need to instantiate this object under a sub-namespace called [namespace capsystem] within your package namespace. # [para]If your package namespace is mypackages::providerpkg then the object command would be at mypackages::providerpkg::capsystem::capprovider.registration # [para]Example code for your provider package to evaluate within its namespace: # [example { #namespace eval capsystem { # if {[info commands capprovider.registration] eq ""} { # punk::cap::class::interface_capprovider.registration create capprovider.registration # oo::objdefine capprovider.registration { # method get_declarations {} { # set decls [list] # lappend decls [list punk.templates {relpath ../templates}] # lappend decls [list another_capability_name {somekey blah key2 etc}] # return $decls # } # } # } #} #}] #[para] The above example declares that your package can be registered as a provider for the capabilities named 'punk.templates' and 'another_capability_name' # [list_begin definitions] # [para] [emph METHODS] method get_declarations {} { #*** #[call class::interface_capprovider.registration [method get_declarations]] #[para] This method must be overridden by your provider using oo::objdefine cappprovider.registration as in the example above. # There must be at least one 2-element list in the result for the provider to be registerable. #[para]The first element of the list is the capabilityname - which can be custom to your provider/handler packages - or a well-known name that other authors may use/implement. #[para]The second element is a dictionary of keys specific to the capability being implemented. It may be empty if the any potential capability handlers for the named capability don't require registration data. error "interface_capprovider.registration not implemented by provider" } #*** !doctools # [list_end] } oo::class create ::punk::cap::class::interface_capprovider.provider { #*** !doctools # [enum] CLASS [class interface_capprovider.provider] # [para] Your provider package will need to instantiate this directly under it's own namespace with the command name of [emph {provider}] # [example { # namespace eval mypackages::providerpkg { # punk::cap::class::interface_capprovider.provider create provider mypackages::providerpkg # } # }] # [list_begin definitions] # [para] [emph METHODS] variable provider_pkg variable registrationobj constructor {providerpkg} { #*** !doctools #[call class::interface_capprovider.provider [method constructor] [arg providerpkg]] variable provider_pkg if {$providerpkg in {"" "::"}} { 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 {[tcl::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" } #review - what are we trying to achieve here? set provider_pkg [tcl::string::trim $providerpkg ""] } method register {{capabilityname_glob *}} { #*** !doctools #[comment {- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---}] #[call class::interface_capprovider.provider [method register] [opt capabilityname_glob]] # #[para]This is the mechanism by which a user of your provider package will register your package as a provider of the capability named. # #[para]A user of your provider may elect to register all your declared capabilities: #[example { # package require mypackages::providerpkg # mypackages::providerpkg::provider register * #}] #[para] Or a specific capability may be registered: #[example { # package require mypackages::providerpkg # mypackages::providerpkg::provider register another_capability_name #}] # 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 {} { #*** !doctools #[comment {- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---}] #[call class::interface_capprovider.provider [method capabilities]] #[para] return a list of capabilities supported by this provider package 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 $capabilities } #*** !doctools # [list_end] [comment {- end class definitions -}] } #*** !doctools # [list_end] [comment {- end enumeration provider_classes }] #[list_end] [comment {- end itemized list punk::cap::class groupings -}] } } ;# end namespace class #*** !doctools #[subsection {Namespace punk::cap}] #[para] Main punk::cap API for client programs interested in using capability handler packages and associated (registered) provider packages #[list_begin definitions] #Not all capability names have to be registered. #A package registering as a provider using register_package can include capabilitynames in it's capabilitylist which have no associated 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} { #puts stderr "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 {![tcl::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 [capability_get_handler $capname]] ne ""} { puts stderr "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" return } #assertion: 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. tcl::dict::set caps $capname handler $capnamespace if {![tcl::dict::exists $caps $capname providers]} { tcl::dict::set caps $capname providers [list] } if {[llength [set providers [tcl::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 [tcl::dict::get $pkgcapsdeclared $pkg] set capname_capabilitylist [lsearch -all -inline -index 0 $fullcapabilitylist $capname] foreach capspec $capname_capabilitylist { lassign $capspec cn capdict #if {$cn ne $capname} { # continue #} if {[catch {$capreg pkg_register $pkg $capdict $fullcapabilitylist} do_register]} { puts stderr "punk::cap::register_capabilityname '$capname' '$capnamespace' failed to register provider package '$pkg' - possible error in handler or provider" puts stderr "error message:" puts stderr $do_register set do_register 0 } set list_accepted [tcl::dict::get $pkgcapsaccepted $pkg] if {$do_register} { if {$capspec ni $list_accepted} { tcl::dict::lappend pkgcapsaccepted $pkg $capspec } } else { set posn [lsearch $list_accepted $capspec] if {$posn >=0} { set list_accepted [lreplace $list_accepted $posn $posn] tcl::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 [tcl::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] tcl::dict::set caps $capname providers $updated_providers } } } } } } proc capability_exists {capname} { #*** !doctools # [call [fun capability_exists] [arg capname]] # Return a boolean indicating if the named capability exists (0|1) variable caps return [tcl::dict::exists $caps $capname] } proc capability_has_handler {capname} { #*** !doctools # [call [fun capability_has_handler] [arg capname]] #Return a boolean indicating if the named capability has a handler package installed (0|1) variable caps return [expr {[tcl::dict::exists $caps $capname handler] && [tcl::dict::get $caps $capname handler] ne ""}] } proc capability_get_handler {capname} { #*** !doctools # [call [fun capability_get_handler] [arg capname]] #Return the base namespace of the active handler package for the named capability. #[para] The base namespace for a handler will always be the package name, but prefixed with :: variable caps if {[tcl::dict::exists $caps $capname]} { return [tcl::dict::get $caps $capname handler] } return "" } proc call_handler {capname args} { if {[set handler [capability_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 {[tcl::dict::exists $caps $capname]} { return [tcl::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 or possibly an implementation of an API, that the capability will use. proc register_package {pkg capabilitylist args} { variable pkgcapsdeclared variable pkgcapsaccepted variable caps set opts [dict create\ -nowarnings false ] foreach {k v} $args { switch -- $k { -nowarnings { tcl::dict::set opts $k $v } default { error "Unrecognized option $k. Known options [tcl::dict::keys $opts]" } } } set warnings [expr {! [tcl::dict::get $opts -nowarnings]}] if {[tcl::string::match ::* $pkg]} { set pkg [tcl::string::range $pkg 2 end] } if {[tcl::dict::exists $pkgcapsaccepted $pkg]} { set pkg_already_accepted [tcl::dict::get $pkgcapsaccepted $pkg] } else { set pkg_already_accepted [list] } package require $pkg set providerapi ::${pkg}::provider if {[tcl::info::commands $providerapi] eq ""} { error "register_package error. pkg '$pkg' doesn't seem to be a punk::cap capability provider (no object found at $providerapi)" } set defined_caps [$providerapi capabilities] #for each capability # - ensure 1st element is a single word # - ensure that if 2nd element (capdict) is present - it is dict shaped set capabilitylist_count [llength $capabilitylist] set accepted_count 0 set errorlist [list];# list of dicts set warninglist [list] foreach capspec $capabilitylist { lassign $capspec capname capdict if {$warnings} { if {$capname ni $defined_caps} { puts stderr "WARNING: pkg '$pkg' doesn't declare support for capability '$capname'." } } if {[llength $capname] !=1} { puts stderr "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$capspec'" set reason "First element of capspec not a single-word name" lappend errorlist [tcl::dict::create msg $reason capspec $capspec] continue } if {[expr {[llength $capdict] %2 != 0}]} { puts stderr "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$capspec'" set reason "The second element of the capspec isn't a valid dict" lappend errorlist [tcl::dict::create msg $reason capspec $capspec] continue } if {$capspec in $pkg_already_accepted} { #review - multiple handlers? if so - will need to record which handler(s) accepted the capspec if {$warnings} { puts stderr "WARNING: register_package pkg $pkg already has capspec marked as accepted: $capspec" } lappend warninglist [tcl::dict::create msg "pkg $pkg already has this capspec marked as accepted" capspec $capspec] continue } if {[tcl::dict::exists $caps $capname]} { set cap_pkgs [tcl::dict::get $caps $capname providers] } else { dict set caps $capname [tcl::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 tcl::dict::set caps $capname providers $cap_pkgs } tcl::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 {[tcl::dict::exists $pkgcapsdeclared $pkg]} { #review - untested set mergecapspecs [tcl::dict::get $pkgcapsdeclared $pkg] foreach spec $capabilitylist { if {$spec ni $mergecapspecs} { lappend mergecapspecs $spec } } tcl::dict::set pkgcapsdeclared $pkg $mergecapspecs } else { tcl::dict::set pkgcapsdeclared $pkg $capabilitylist } set resultdict [list num_capabilities $capabilitylist_count num_accepted $accepted_count] if {[llength $errorlist]} { tcl::dict::set resultdict errors $errorlist } if {[llength $warninglist]} { tcl::dict::set resultdict warnings $warninglist } return $resultdict } #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 } } proc pkgcap {pkg {capsearch}} { 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 [lsearch -all -inline -glob -index 0 [dict get $pkgcapsaccepted $pkg] $capsearch] } return [dict create declared [lsearch -all -inline -glob -index 0 [dict get $pkgcapsdeclared $pkg] $capsearch] 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 } #*** !doctools #[list_end] [comment {- end definitions for namespace punk::cap -}] namespace eval advanced { #*** !doctools #[subsection {Namespace punk::cap::advanced}] #[para] punk::cap::advanced API. Functions here are generally not the preferred way to interact with punk::cap. #[para] In some cases they may allow interaction in less safe ways or may allow use of features that are unavailable in the base namespace. #[para] Some functions are here because they are only marginally or rarely useful, and they are here to keep the base API simple. #[list_begin definitions] proc promote_provider {pkg} { #*** !doctools # [call advanced::[fun promote_provider] [arg pkg]] #[para]Move the named provider package to the preferred end of the list (tail). #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. #[para] #[para] promote/demote doesn't always make a lot of sense .. should preferably be configurable per capapbility for multicap provider pkgs #[para]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 #[para]The order of providers will be the order the packages were loaded & registered #[para]the naming: "promote vs demote" operates on a latest-package-in-list has higher preference assumption (matching last pkg loaded) #[para]Each capability handler could and should implement specific preferencing methods within its own API if finer control needed. #In some cases the preference/loading order may be inapplicable/irrelevant to a particular capability anyway. #[para]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. #[para]Whether particular caps or users of caps do anything with this ordering is dependent on the cap-handler and/or calling code. 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_provider {pkg} { #*** !doctools # [call advanced::[fun demote_provider] [arg pkg]] #[para]Move the named provider package to the preferred end of the list (tail). #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. 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 } } } } } #*** !doctools #[list_end] } #*** !doctools #[section Internal] namespace eval capsystem { #*** !doctools #[subsection {Namespace punk::cap::capsystem}] #[para] Internal functions used to communicate between punk::cap and capability handlers #[list_begin definitions] proc get_caphandler_registry {capname} { set ns [::punk::cap::capability_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 "" } #*** !doctools #[list_end] } } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::cap [namespace eval punk::cap { variable version variable pkg punk::cap set version 999999.0a1.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 #[manpage_end]