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 17# The try command is used in the namespacex::import command. For 18# backward compatibility we will use the try package from tcllib if 19# running on a platform that does not have it as a core command, 20# i.e. before 8.6. 21 22if {![llength [info commands try]]} { 23 package require try ; # tcllib 24} 25 26namespace eval ::namespacex { 27 namespace export add hook info import normalize strip state 28 namespace ensemble create 29 30 namespace eval hook { 31 namespace export add proc on next 32 namespace ensemble create 33 34 # add - hook a command prefix into the chain of unknown handlers for a 35 # namespace. The prefix will be run with whatever args there are, so 36 # it should use 'args' to accomodate? to everything. 37 38 # on - ditto for separate guard and action command prefixes. 39 # If the guard fails it chains via next, otherwise the 40 # action runs. The action can asume that the guard checked for proper 41 # number of arguments, maybe even types. Whatever fits. 42 43 # proc - like add, but an unamed procedure, with arguments and 44 # body. Not much use, except maybe to handle the exact way 45 # of chaining on your own (next can take a rewritten 46 # command, the 'on' compositor makes no use of that. 47 48 # Both 'proc' and 'on' are based on 'add'. 49 } 50 51 namespace eval info { 52 namespace export allvars allchildren vars 53 namespace ensemble create 54 } 55 56 namespace eval state { 57 namespace export drop set get 58 namespace ensemble create 59 } 60} 61 62# # ## ### ##### ######## ############# ###################### 63## Implementation :: Hooks - Visible API 64 65# # ## ### ##### ######## ############# ###################### 66## (1) Core: Register a command prefix to be run by 67## namespace unknown of a namespace FOO. 68## FOO defaults to the current namespace. 69## 70## The prefixes are executed in reverse order of registrations, 71## i.e. the prefix registered last is executed first. The next 72## is run if and only if the current prefix forced this via 73## '::namespacex::hook::next'. IOW the chain is managed cooperatively. 74 75proc ::namespacex::hook::add {args} { 76 # syntax: ?namespace? cmdprefix 77 78 if {[llength $args] > 2} { 79 return -code error "wrong\#args, should be \"?namespace? cmdprefix\"" 80 } elseif {[llength $args] == 2} { 81 lassign $args namespace cmdprefix 82 } else { # [llength $args] == 1 83 lassign $args cmdprefix 84 set namespace [uplevel 1 { namespace current }] 85 } 86 87 #puts UH|ADD|for|$namespace| 88 #puts UH|ADD|old|<<[Get $namespace]>> 89 #puts UH|ADD|cmd|<<$cmdprefix>> 90 91 Set $namespace [namespace code [list Handle $cmdprefix [Get $namespace]]] 92 return 93} 94 95proc ::namespacex::hook::proc {args} { 96 # syntax: ?namespace? arguments body 97 98 set procNamespace [uplevel 1 { namespace current }] 99 100 if {([llength $args] < 2) || 101 ([llength $args] > 3)} { 102 return -code error "wrong\#args, should be \"?namespace? arguments body\"" 103 } elseif {[llength $args] == 3} { 104 lassign $args namespace arguments body 105 } else { # [llength $args] == 2 106 lassign $args arguments body 107 set namespace $procNamespace 108 } 109 110 add $namespace [list ::apply [list $arguments $body $procNamespace]] 111 return 112} 113 114proc ::namespacex::hook::on {args} { 115 # syntax: ?namespace? guardcmd actioncmd 116 117 if {([llength $args] < 2) || 118 ([llength $args] > 3)} { 119 return -code error "wrong\#args, should be \"?namespace? guard action\"" 120 } elseif {[llength $args] == 3} { 121 lassign $args namespace guard action 122 } else { # [llength $args] == 2 123 lassign $args guard action 124 set namespace [uplevel 1 { namespace current }] 125 } 126 127 add $namespace [list ::apply [list {guard action args} { 128 if {![{*}$guard {*}$args]} { 129 # This is what requires '[ns current]' as context. 130 next 131 } 132 return [{*}$action {*}$args] 133 } [namespace current]] $guard $action] 134 return 135} 136 137proc ::namespacex::hook::next {args} { 138 #puts UH|NEXT|$args| 139 return -code continue -level 2 $args 140} 141 142# # ## ### ##### ######## ############# ###################### 143## Implementation :: Hooks - Internal Helpers. 144## Get and set the unknown handler for a specified namespace. 145 146# Generic handler with the user's handler and previous handler as 147# arguments. The latter is an invokation of the internal handler 148# again, with its own arguments. In this way 'Handle' forms the spine 149# of the chain of handlers, running them and handling 'next' to 150# traverse the chain. From a data structure perspective we have deeply 151# nested list here, which is recursed into as the chain is traversed. 152 153proc ::namespacex::hook::Get {ns} { 154 return [namespace eval $ns { namespace unknown }] 155} 156 157proc ::namespacex::hook::Set {ns handler} { 158 #puts UH|SET|$ns|<<$handler>> 159 160 namespace eval $ns [list namespace unknown $handler] 161 return 162} 163 164proc ::namespacex::hook::Handle {handler old args} { 165 #puts UH|HDL|$handler|||old|$old||args||$args| 166 167 set rc [catch { 168 uplevel 1 $handler $args 169 } result] 170 171 #puts UH|HDL|rc=$rc|result=$result| 172 173 if {$rc == 4} { 174 # continue - invoke next handler 175 176 if {$old eq {}} { 177 # no next handler available - stop 178 #puts UH|HDL|STOP 179 return -code error "invalid command name \"[lindex $args 0]\"" 180 } 181 182 if {![llength $result]} { 183 uplevel 1 $old $args 184 } else { 185 uplevel 1 $old $result 186 } 187 } else { 188 return -code $rc $result 189 } 190} 191 192# # ## ### ##### ######## ############# ###################### 193## Implementation :: Info - Visible API 194 195proc ::namespacex::import {from args} { 196 set upns [uplevel 1 {::namespace current}] 197 if {![string match ::* $from]} { 198 set from ${upns}::$from[set from {}] 199 } 200 set orig [namespace eval $from {::namespace export}] 201 try { 202 namespace eval $from {::namespace export *} 203 set tmp [::namespace current]::[::info cmdcount] 204 namespace eval $tmp [list ::namespace import ${from}::*] 205 if {[llength $args] == 1} { 206 lappend args [lindex $args 0] 207 } 208 dict size $args 209 foreach {old new} $args { 210 rename ${tmp}::$old ${upns}::$new 211 } 212 namespace delete $tmp 213 } finally { 214 namespace eval $from [list ::namespace export -clear {*}$orig] 215 } 216 return 217} 218 219proc ::namespacex::info::allvars {ns} { 220 set ns [uplevel 1 [list [namespace parent] normalize $ns]] 221 ::set result [::info vars ${ns}::*] 222 foreach cns [allchildren $ns] { 223 lappend result {*}[::info vars ${cns}::*] 224 } 225 return [::namespacex::Strip $ns $result] 226} 227 228proc ::namespacex::info::allchildren {ns} { 229 set ns [uplevel 1 [list [namespace parent] normalize $ns]] 230 ::set result [list] 231 foreach cns [::namespace children $ns] { 232 lappend result {*}[allchildren $cns] 233 lappend result $cns 234 } 235 return $result 236} 237 238proc ::namespacex::info::vars {ns {pattern *}} { 239 set ns [uplevel 1 [list [namespace parent] normalize $ns]] 240 return [::namespacex::Strip $ns [::info vars ${ns}::$pattern]] 241} 242 243# this implementation avoids string operations 244proc ::namespacex::normalize {ns} { 245 if {[uplevel 1 [list ::namespace exists $ns]]} { 246 return [uplevel 1 [list namespace eval $ns {::namespace current}]] 247 } 248 if {![string match ::* $ns]} { 249 set ns [uplevel 1 {::namespace current}]::$ns 250 } 251 regsub {::+} $ns :: ns 252 return $ns 253} 254 255proc ::namespacex::strip {ns itemlist} { 256 set ns [uplevel 1 [list [namespace current] normalize $ns]] 257 set n [string length $ns] 258 incr n -1 259 foreach i $itemlist { 260 if {[string range $i 0 $n] eq "$ns"} continue 261 return -code error "Expected $ns as prefix for $i, not found" 262 } 263 return [Strip $ns $itemlist] 264} 265 266proc ::namespacex::Strip {ns itemlist} { 267 # Assert: is-fqn (ns) 268 if {![string match {::*} $ns]} { error "Expected fqn for ns" } 269 270 set n [string length $ns] 271 incr n 2 272 273 set result {} 274 foreach i $itemlist { 275 lappend result [string range $i $n end] 276 } 277 return $result 278} 279 280# # ## ### ##### ######## ############# ###################### 281## Implementation :: State - Visible API 282 283proc ::namespacex::state::drop {ns} { 284 ::set ns [uplevel 1 [list [namespace parent] normalize $ns]] 285 namespace eval $ns [list ::unset {*}[::namespacex info allvars $ns]] 286 return 287} 288 289proc ::namespacex::state::get {ns} { 290 ::set ns [uplevel 1 [list [namespace parent] normalize $ns]] 291 ::set result {} 292 foreach v [::namespacex info allvars $ns] { 293 namespace upvar $ns $v value 294 lappend result $v $value 295 } 296 return $result 297} 298 299proc ::namespacex::state::set {ns state} { 300 ::set ns [uplevel 1 [list [namespace parent] normalize $ns]] 301 # Inlined 'state drop'. 302 namespace eval $ns [list ::unset {*}[::namespacex info allvars $ns]] 303 namespace eval $ns [list variable {*}$state] 304 return 305} 306 307# # ## ### ##### ######## ############# ###################### 308## Ready 309 310package provide namespacex 0.2 311