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