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