1## -*- tcl -*- 2## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> 3## 'unknown hook' code -- Derived from http://wiki.tcl.tk/12790 (Neil Madden). 4## 'var/state' code -- Derived from http://wiki.tcl.tk/1489 (various). 5## BSD Licensed 6# # ## ### ##### ######## ############# ###################### 7 8# namespacex hook - Easy extensibility of 'namespace unknown'. 9# namespacex info - Get all variables/children, direct and indirect 10# namespacex state - Save/restore the variable-based state of namespaces. 11 12# # ## ### ##### ######## ############# ###################### 13## Requisites 14 15package require Tcl 8.5 ; # namespace ensembles, {*} 16 17namespace eval ::namespacex { 18 namespace export add hook info state 19 namespace ensemble create 20 21 namespace eval hook { 22 namespace export add proc on next 23 namespace ensemble create 24 25 # add - hook a command prefix into the chain of unknown handlers for a 26 # namespace. The prefix will be run with whatever args there are, so 27 # it should use 'args' to accomodate? to everything. 28 29 # on - ditto for separate guard and action command prefixes. 30 # If the guard fails it chains via next, otherwise the 31 # action runs. The action can asume that the guard checked for proper 32 # number of arguments, maybe even types. Whatever fits. 33 34 # proc - like add, but an unamed procedure, with arguments and 35 # body. Not much use, except maybe to handle the exact way 36 # of chaining on your own (next can take a rewritten 37 # command, the 'on' compositor makes no use of that. 38 39 # Both 'proc' and 'on' are based on 'add'. 40 } 41 42 namespace eval info { 43 namespace export allvars allchildren vars 44 namespace ensemble create 45 } 46 47 namespace eval state { 48 namespace export drop set get 49 namespace ensemble create 50 } 51} 52 53# # ## ### ##### ######## ############# ###################### 54## Implementation :: Hooks - Visible API 55 56# # ## ### ##### ######## ############# ###################### 57## (1) Core: Register a command prefix to be run by 58## namespace unknown of a namespace FOO. 59## FOO defaults to the current namespace. 60## 61## The prefixes are executed in reverse order of registrations, 62## i.e. the prefix registered last is executed first. The next 63## is run if and only if the current prefix forced this via 64## '::namespacex::hook::next'. IOW the chain is managed cooperatively. 65 66proc ::namespacex::hook::add {args} { 67 # syntax: ?namespace? cmdprefix 68 69 if {[llength $args] > 2} { 70 return -code error "wrong\#args, should be \"?namespace? cmdprefix\"" 71 } elseif {[llength $args] == 2} { 72 lassign $args namespace cmdprefix 73 } else { # [llength $args] == 1 74 lassign $args cmdprefix 75 set namespace [uplevel 1 { namespace current }] 76 } 77 78 #puts UH|ADD|for|$namespace| 79 #puts UH|ADD|old|<<[Get $namespace]>> 80 #puts UH|ADD|cmd|<<$cmdprefix>> 81 82 Set $namespace [namespace code [list Handle $cmdprefix [Get $namespace]]] 83 return 84} 85 86proc ::namespacex::hook::proc {args} { 87 # syntax: ?namespace? arguments body 88 89 set procNamespace [uplevel 1 { namespace current }] 90 91 if {([llength $args] < 2) || 92 ([llength $args] > 3)} { 93 return -code error "wrong\#args, should be \"?namespace? arguments body\"" 94 } elseif {[llength $args] == 3} { 95 lassign $args namespace arguments body 96 } else { # [llength $args] == 2 97 lassign $args arguments body 98 set namespace $procNamespace 99 } 100 101 add $namespace [list ::apply [list $arguments $body $procNamespace]] 102 return 103} 104 105proc ::namespacex::hook::on {args} { 106 # syntax: ?namespace? guardcmd actioncmd 107 108 if {([llength $args] < 2) || 109 ([llength $args] > 3)} { 110 return -code error "wrong\#args, should be \"?namespace? guard action\"" 111 } elseif {[llength $args] == 3} { 112 lassign $args namespace guard action 113 } else { # [llength $args] == 2 114 lassign $args guard action 115 set namespace [uplevel 1 { namespace current }] 116 } 117 118 add $namespace [list ::apply [list {guard action args} { 119 if {![{*}$guard {*}$args]} { 120 # This is what requires '[ns current]' as context. 121 next 122 } 123 return [{*}$action {*}$args] 124 } [namespace current]] $guard $action] 125 return 126} 127 128proc ::namespacex::hook::next {args} { 129 #puts UH|NEXT|$args| 130 return -code continue -level 2 $args 131} 132 133# # ## ### ##### ######## ############# ###################### 134## Implementation :: Hooks - Internal Helpers. 135## Get and set the unknown handler for a specified namespace. 136 137# Generic handler with the user's handler and previous handler as 138# arguments. The latter is an invokation of the internal handler 139# again, with its own arguments. In this way 'Handle' forms the spine 140# of the chain of handlers, running them and handling 'next' to 141# traverse the chain. From a data structure perspective we have deeply 142# nested list here, which is recursed into as the chain is traversed. 143 144proc ::namespacex::hook::Get {ns} { 145 return [namespace eval $ns { namespace unknown }] 146} 147 148proc ::namespacex::hook::Set {ns handler} { 149 #puts UH|SET|$ns|<<$handler>> 150 151 namespace eval $ns [list namespace unknown $handler] 152 return 153} 154 155proc ::namespacex::hook::Handle {handler old args} { 156 #puts UH|HDL|$handler|||old|$old||args||$args| 157 158 set rc [catch { 159 uplevel 1 $handler $args 160 } result] 161 162 #puts UH|HDL|rc=$rc|result=$result| 163 164 if {$rc == 4} { 165 # continue - invoke next handler 166 167 if {$old eq {}} { 168 # no next handler available - stop 169 #puts UH|HDL|STOP 170 return -code error "invalid command name \"[lindex $args 0]\"" 171 } 172 173 if {![llength $result]} { 174 uplevel 1 $old $args 175 } else { 176 uplevel 1 $old $result 177 } 178 } else { 179 return -code $rc $result 180 } 181} 182 183# # ## ### ##### ######## ############# ###################### 184## Implementation :: Info - Visible API 185 186proc ::namespacex::info::allvars {ns} { 187 if {![string match {::*} $ns]} { set ns ::$ns } 188 ::set result [::info vars ${ns}::*] 189 foreach cns [allchildren $ns] { 190 lappend result {*}[::info vars ${cns}::*] 191 } 192 return [Strip $ns $result] 193} 194 195proc ::namespacex::info::allchildren {ns} { 196 if {![string match {::*} $ns]} { set ns ::$ns } 197 ::set result [list] 198 foreach cns [::namespace children $ns] { 199 lappend result {*}[allchildren $cns] 200 lappend result $cns 201 } 202 return $result 203} 204 205proc ::namespacex::info::vars {ns {pattern *}} { 206 return [Strip $ns [::info vars ${ns}::$pattern]] 207} 208 209proc ::namespacex::info::Strip {ns itemlist} { 210 set n [string length $ns] 211 if {![string match {::*} $ns]} { 212 incr n 4 213 } else { 214 incr n 2 215 } 216 217 set result {} 218 foreach i $itemlist { 219 lappend result [string range $i $n end] 220 } 221 return $result 222} 223 224# # ## ### ##### ######## ############# ###################### 225## Implementation :: State - Visible API 226 227proc ::namespacex::state::drop {ns} { 228 if {![string match {::*} $ns]} { ::set ns ::$ns } 229 namespace eval $ns [list ::unset {*}[::namespacex info allvars $ns]] 230 return 231} 232 233proc ::namespacex::state::get {ns} { 234 if {![string match {::*} $ns]} { ::set ns ::$ns } 235 ::set result {} 236 foreach v [::namespacex info allvars $ns] { 237 namespace upvar $ns $v value 238 lappend result $v $value 239 } 240 return $result 241} 242 243proc ::namespacex::state::set {ns state} { 244 if {![string match {::*} $ns]} { ::set ns ::$ns } 245 # Inlined 'state drop'. 246 namespace eval $ns [list ::unset {*}[::namespacex info allvars $ns]] 247 namespace eval $ns [list variable {*}$state] 248 return 249} 250 251# # ## ### ##### ######## ############# ###################### 252## Ready 253 254package provide namespacex 0.1 255