TaoLib

Check-in [06416af04b]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Adding a snapshot of every tcllib module tool and tao depend on
Timelines: family | ancestors | descendants | both | fsar
Files: files | file ages | folders
SHA1:06416af04b0a93539b2aa7d03677bd814e7dfb43
User & Date: hypnotoad 2018-12-05 15:23:34
Context
2018-12-11
23:01
New build of tool Leaf check-in: 300e317280 user: hypnotoad tags: fsar
2018-12-05
15:23
Adding a snapshot of every tcllib module tool and tao depend on check-in: 06416af04b user: hypnotoad tags: fsar
2018-11-30
21:42
Update the build for taotk-form.tcl check-in: 9e680e2748 user: hypnotoad tags: fsar
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Added modules/coroutine/ChangeLog.



















































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
2013-05-31  Andreas Kupries  <andreask@activestate.com>

	* coroutine.tcl: Added Colin Macleod and http://wiki/21555
	* coro_auto.tcl: to the set of acknowledged contributors
	  and references for the module.

2013-05-15  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* coro_auto.tcl: Replaced uses of 'namespace current' in the wrap_
	* coro_auto.man: commands with a hardwired namespace name. As the
	  wrappers get renamed into different namespaces (:: and
	  ::tcl::chan) the result of 'namespace current' points to the
	  wrong namespace, causing the commands to miss the renamed
	  builtins, and fail. Bumped version to 1.1.1
	* pkgIndex.tcl: Updated version numbers.

2013-03-04  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* coroutine.man: Renamed, clashes with Tcl core manpage.
	* tcllib_coroutine.man: New name.

2013-02-08  Andreas Kupries  <andreask@activestate.com>

	* coroutine.man: Fixed missing short package title.
	* coro_auto.man: Ditto.

2013-02-01  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.15 ========================
	*

2011-12-13  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.14 ========================
	*

2011-04-18  Andreas Kupries  <andreask@activestate.com>

	* coroutine.tcl: [Bug 3252952]: Fixed clash between ::coroutine
	* coroutine.man: builtin of Tcl 8.6, and the same-named ensemble
	  of the package. Moved package command ::coroutine to
	  ::coroutine::util. Bumped version to 1.1.

	* coro_auto.tcl: [Bug 3252952]: Updated user of package coroutine
	* coro_auto.man: to the new command name. Bumped version to 1.1.

	* pkgIndex.tcl: Updated version numbers.

2011-01-24  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.13 ========================
	*

2010-08-17  Andreas Kupries  <andreask@activestate.com>

	* coroutine.man: Added package documentation.
	* coro_auto.man:

2009-12-07  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.12 ========================
	*

2009-11-10  Andreas Kupries  <andreask@activestate.com>

	* New module 'coroutine' providing to coroutine utility packages
	  for easier use of channel operations. These packages are for Tcl
	  8.6+.

Added modules/coroutine/coro_auto.man.





























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
[comment {-*- tcl -*- doctools manpage}]
[vset CORO_AUTO_VERSION 1.1.3]
[manpage_begin coroutine::auto n [vset CORO_AUTO_VERSION]]
[keywords after]
[keywords channel]
[keywords coroutine]
[keywords events]
[keywords exit]
[keywords gets]
[keywords global]
[keywords {green threads}]
[keywords read]
[keywords threads]
[keywords update]
[keywords vwait]
[copyright {2010-2014 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
[moddesc   {Coroutine utilities}]
[category  Coroutine]
[titledesc {Automatic event and IO coroutine awareness}]
[require Tcl 8.6]
[require coroutine::auto [vset CORO_AUTO_VERSION]]
[require coroutine 1.1]
[description]

The [package coroutine::auto] package provides no commands or other
directly visible functionality.

Built on top of the package [package coroutine], it intercepts various
builtin commands of the Tcl core to make any code using them
coroutine-oblivious, i.e. able to run inside and outside of a
coroutine without changes.

[para] The commands so affected by this package are
[list_begin definitions]
[def [cmd after]]
[def [cmd exit]]
[def [cmd gets]]
[def [cmd global]]
[def [cmd read]]
[def [cmd update]]
[def [cmd vwait]]
[list_end]

[vset CATEGORY coroutine]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

Added modules/coroutine/coro_auto.tcl.

























































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
## -- Tcl Module -- -*- tcl -*-
# # ## ### ##### ######## #############

# @@ Meta Begin
# Package coroutine::auto 1.1.2
# Meta platform        tcl
# Meta require         {Tcl 8.6}
# Meta require         {coroutine 1.1}
# Meta license         BSD
# Meta as::author      {Andreas Kupries}
# Meta as::origin      http://wiki.tcl.tk/21555
# Meta summary         Coroutine Event and Channel Support
# Meta description     Built on top of coroutine, this
# Meta description     package intercepts various builtin
# Meta description     commands to make the code using them
# Meta description     coroutine-oblivious, i.e. able to run
# Meta description     inside and outside of a coroutine
# Meta description     without changes.
# @@ Meta End

# Copyright (c) 2009-2014 Andreas Kupries

## $Id: coro_auto.tcl,v 1.3 2011/11/17 08:00:45 andreas_kupries Exp $
# # ## ### ##### ######## #############
## Requisites, and ensemble setup.

package require Tcl 8.6
package require coroutine

namespace eval ::coroutine::auto {}

# # ## ### ##### ######## #############
## API implementations. Uses the coroutine commands where
## possible.

proc ::coroutine::auto::wrap_global {args} {
    if {[info coroutine] eq {}} {
	tailcall ::coroutine::auto::core_global {*}$args
    }

    tailcall ::coroutine::util::global {*}$args
}

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_after {delay args} {
    if {
	([info coroutine] eq {}) ||
	([llength $args] > 0)
    } {
	# We use the core builtin when called from either outside of a
	# coroutine, or for an asynchronous delay.

	tailcall ::coroutine::auto::core_after $delay {*}$args
    }

    # Inside of coroutine, and synchronous delay (args == "").
    tailcall ::coroutine::util::after $delay
}

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_exit {{status 0}} {
    if {[info coroutine] eq {}} {
	tailcall ::coroutine::auto::core_exit $status
    }

    tailcall ::coroutine::util::exit $status
}

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_vwait {varname} {
    if {[info coroutine] eq {}} {
	tailcall ::coroutine::auto::core_vwait $varname
    }

    tailcall ::coroutine::util::vwait $varname
}

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_update {{what {}}} {
    if {[info coroutine] eq {}} {
	tailcall ::coroutine::auto::core_update {*}$what
    }

    # This is a full re-implementation of mode (1), because the
    # coroutine-aware part uses the builtin itself for some
    # functionality, and this part cannot be taken as is.

    if {$what eq "idletasks"} {
        after idle [info coroutine]
    } elseif {$what ne {}} {
        # Force proper error message for bad call.
        tailcall ::coroutine::auto::core_update $what
    } else {
        after 0 [info coroutine]
    }
    yield
    return
} 

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_gets {args} {
    # Process arguments.
    # Acceptable syntax:
    # * gets CHAN ?VARNAME?

    if {[info coroutine] eq {}} {
	tailcall ::coroutine::auto::core_gets {*}$args
    }

    # This is a full re-implementation of mode (1), because the
    # coroutine-aware part uses the builtin itself for some
    # functionality, and this part cannot be taken as is.

    if {[llength $args] == 2} {
	# gets CHAN VARNAME
	lassign $args chan varname
        upvar 1 $varname line
    } elseif {[llength $args] == 1} {
	# gets CHAN
	lassign $args chan
    } else {
	# not enough, or too many arguments (0, or > 2): Calling the
	# builtin gets command with the bogus arguments gives us the
	# necessary error with the proper message.
	tailcall ::coroutine::auto::core_gets {*}$args
    }

    # Loop until we have a complete line. Yield to the event loop
    # where necessary. During 

    while {1} {
        set blocking [::chan configure $chan -blocking]
        ::chan configure $chan -blocking 0

	try {
	    set result [::coroutine::auto::core_gets $chan line]
	} on error {result opts} {
            ::chan configure $chan -blocking $blocking
            return -code $result -options $opts
	}

	if {[::chan blocked $chan]} {
            ::chan event $chan readable [list [info coroutine]]
            yield
            ::chan event $chan readable {}
        } else {
            ::chan configure $chan -blocking $blocking

            if {[llength $args] == 2} {
                return $result
            } else {
                return $line
            }
        }
    }
}

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_read {args} {
    # Process arguments.
    # Acceptable syntax:
    # * read ?-nonewline ? CHAN
    # * read               CHAN ?n?

    if {[info coroutine] eq {}} {
	tailcall ::coroutine::auto::core_read {*}$args
    }

    # This is a full re-implementation of mode (1), because the
    # coroutine-aware part uses the builtin itself for some
    # functionality, and this part cannot be taken as is.

    if {[llength $args] > 2} {
	# Calling the builtin read command with the bogus arguments
	# gives us the necessary error with the proper message.
	::coroutine::auto::core_read {*}$args
	return
    }

    set total Inf ; # Number of characters to read. Here: Until eof.
    set chop  no  ; # Boolean flag. Determines if we have to trim a
    #               # \n from the end of the read string.

    if {[llength $args] == 2} {
	lassign $args a b
	if {$a eq "-nonewline"} {
	    set chan $b
	    set chop yes
	} else {
	    lassign $args chan total
	}
    } else {
	lassign $args chan
    }

    # Run the read loop. Yield to the event loop where
    # necessary. Differentiate between loop until eof, and loop until
    # n characters have been read (or eof reached).

    set buf {}

    if {$total eq "Inf"} {
	# Loop until eof.

	while {1} {
	    set blocking [::chan configure $chan -blocking]
	    ::chan configure $chan -blocking 0

	    try {
		set result [::coroutine::auto::core_read $chan]
	    } on error {result opts} {
		::chan configure $chan -blocking $blocking
		return -code $result -options $opts
	    }

	    if {[::chan blocked $chan]} {
		::chan event $chan readable [list [info coroutine]]
		yield
		::chan event $chan readable {}
	    } else {
		::chan configure $chan -blocking $blocking
		append buf $result

		if {[::chan eof $chan]} {
		    ::chan close $chan
		    break
		}
	    }
	}
    } else {
	# Loop until total characters have been read, or eof found,
	# whichever is first.

	set left $total
	while {1} {
	    set blocking [::chan configure $chan -blocking]
	    ::chan configure $chan -blocking 0

	    try {
		set result [::coroutine::auto::core_read $chan $left]
	    } on error {result opts} {
		::chan configure $chan -blocking $blocking
		return -code $result -options $opts
	    }

	    if {[::chan blocked $chan]} {
		::chan event $chan readable [list [info coroutine]]
		yield
		::chan event $chan readable {}
	    } else {
		::chan configure $chan -blocking $blocking
		append buf $result
		incr   left -[string length $result]

		if {[::chan eof $chan]} {
		    ::chan close $chan
		    break
		} elseif {!$left} {
		    break
		}
	    }
	}
    }

    if {$chop && [string index $buf end] eq "\n"} {
	set buf [string range $buf 0 end-1]
    }

    return $buf
}

# # ## ### ##### ######## #############
## Internal. Setup.

::apply {{} {
    # Replaces the builtin commands with coroutine-aware
    # counterparts. We cannot use the coroutine commands directly,
    # because the replacements have to use the saved builtin commands
    # when called outside of a coroutine. And some (read, gets,
    # update) even need full re-implementations, as they use the
    # builtin command they replace themselves to implement their
    # functionality.

    foreach cmd {
	global
	exit
	after
	vwait
	update
    } {
	rename ::$cmd [namespace current]::core_$cmd
	rename [namespace current]::wrap_$cmd ::$cmd
    }

    foreach cmd {
	gets
	read
    } {
	rename ::tcl::chan::$cmd [namespace current]::core_$cmd
	rename [namespace current]::wrap_$cmd ::tcl::chan::$cmd
    }

    return
} ::coroutine::auto}

# # ## ### ##### ######## #############
## Ready

package provide coroutine::auto 1.1.3
return

Added modules/coroutine/coroutine.pcx.













































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
# -*- tcl -*- aes.pcx
# Syntax of the commands provided by package coroutine.
#
# For use by TclDevKit's static syntax checker (v4.1+).
# See http://www.activestate.com/solutions/tcl/
# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api
# for the specification of the format of the code in this file.
#

package require pcx
pcx::register coroutine
pcx::tcldep   1 needs tcl 8.6

namespace eval ::coroutine {}

pcx::check 1 std ::coroutine::util::create \
    {checkSimpleArgs 0 -1 {
	checkWord
    }}
pcx::check 1 std ::coroutine::util::global \
    {checkSimpleArgs 0 -1 {
	checkVarDecl
    }}
pcx::check 1 std ::coroutine::util::after \
    {checkSimpleArgs 1 1 {
	checkInt
    }}
pcx::check 1 std ::coroutine::util::exit \
    {checkSimpleArgs 0 1 {
	checkInt
    }}
pcx::check 1 std ::coroutine::util::vwait \
    {checkSimpleArgs 1 1 {
	checkVarName
    }}
pcx::check 1 std ::coroutine::util::await \
    {checkSimpleArgs 0 -1 {
	checkVarName
    }}
pcx::check 1 std ::coroutine::util::update \
    {checkSimpleArgs 0 1 {
	{checkKeyword 0 {idletasks}}
    }}
pcx::check 1 std ::coroutine::util::gets \
    {checkSimpleArgs 1 2 {
	checkChannelID
	checkVarNameWrite
    }}
pcx::check 1 std ::coroutine::util::read \
    {coreTcl::checkReadCmd 0}

# Initialization via pcx::init.
# Use a ::coroutine::init procedure for non-standard initialization.
pcx::complete

Added modules/coroutine/coroutine.tcl.































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
## -- Tcl Module -- -*- tcl -*-
# # ## ### ##### ######## #############

# @@ Meta Begin
# Package coroutine 1.2
# Meta platform        tcl
# Meta require         {Tcl 8.6}
# Meta license         BSD
# Meta as::author      {Andreas Kupries}
# Meta as::author      {Colin Macleod}
# Meta as::author      {Colin McCormack}
# Meta as::author      {Donal Fellows}
# Meta as::author      {Kevin Kenny}
# Meta as::author      {Neil Madden}
# Meta as::author      {Peter Spjuth}
# Meta as::origin      http://wiki.tcl.tk/21555
# Meta summary         Coroutine Event and Channel Support
# Meta description     This package provides coroutine-aware
# Meta description     implementations of various event- and
# Meta description     channel related commands. It can be
# Meta description     in multiple modes: (1) Call the
# Meta description     commands through their ensemble, in
# Meta description     code which is explicitly written for
# Meta description     use within coroutines. (2) Import
# Meta description     the commands into a namespace, either
# Meta description     directly, or through 'namespace path'.
# Meta description     This allows the use from within code
# Meta description     which is not coroutine-aware per se
# Meta description     and restricted to specific namespaces.
# Meta description     A more agressive form of making code
# Meta description     coroutine-oblivious than (2) above is
# Meta description     available through the package
# Meta description     coroutine::auto, which intercepts
# Meta description     the relevant builtin commands and changes
# Meta description     their implementation dependending on the
# Meta description     context they are run in, i.e. inside or
# Meta description     outside of a coroutine.
# @@ Meta End

# Copyright (c) 2009,2014-2015 Andreas Kupries
# Copyright (c) 2009 Colin Macleod
# Copyright (c) 2009 Colin McCormack
# Copyright (c) 2009 Donal Fellows
# Copyright (c) 2009 Kevin Kenny
# Copyright (c) 2009 Neil Madden
# Copyright (c) 2009 Peter Spjuth

## $Id: coroutine.tcl,v 1.2 2011/04/18 20:23:58 andreas_kupries Exp $
# # ## ### ##### ######## #############
## Requisites, and ensemble setup.

package require Tcl 8.6

namespace eval ::coroutine::util {

    namespace export \
	create global after exit vwait update gets read await

    namespace ensemble create
}

# # ## ### ##### ######## #############
## API. Spawn coroutines, automatic naming
##      (like thread::create).

proc ::coroutine::util::create {args} {
    ::coroutine [ID] {*}$args
}

# # ## ### ##### ######## #############
## API.
#
# global (coroutine globals (like thread global storage))
# after  (synchronous).
# exit
# update ?idletasks? [1]
# vwait
# gets               [1]
# read               [1]
#
# [1] These commands call on their builtin counterparts to get some of
#     their functionality (like proper error messages for syntax errors).

# - -- --- ----- -------- -------------

proc ::coroutine::util::global {args} {
    # Frame #1 is the coroutine-specific stack frame at its
    # bottom. Variables there are out of view of the main code, and
    # can be made visible in the entire coroutine underneath.

    set cmd [list upvar "#1"]
    foreach var $args {
	lappend cmd $var $var
    }
    tailcall {*}$cmd
}

# - -- --- ----- -------- -------------

proc ::coroutine::util::after {delay} {
    ::after $delay [info coroutine]
    yield
    return
}

# - -- --- ----- -------- -------------

proc ::coroutine::util::exit {{status 0}} {
    return -level [info level] $status
}

# - -- --- ----- -------- -------------

proc ::coroutine::util::vwait {varname} {
    upvar 1 $varname var
    set callback [list [namespace current]::VWaitTrace [info coroutine]]

    # Step 1. Wait for a write to the variable, using a trace to
    # restart the coroutine

    trace add    variable var write $callback
    yield
    trace remove variable var write $callback

    # Step 2. To prevent the next section of the coroutine code from
    # running entirely within the variable trace (*) we now use an
    # idle handler to defer it until the trace is definitely
    # done. This trick by Peter Spjuth.
    #
    # (*) At this point we are in VWaitTrace running the coroutine.

    ::after idle [info coroutine]
    yield
    return
}

proc ::coroutine::util::VWaitTrace {coroutine args} {
    $coroutine
    return
}

# - -- --- ----- -------- -------------

proc ::coroutine::util::update {{what {}}} {
    if {$what eq "idletasks"} {
        ::after idle [info coroutine]
    } elseif {$what ne {}} {
        # Force proper error message for bad call.
        tailcall ::tcl::update $what
    } else {
        ::after 0 [info coroutine]
    }
    yield
    return
}

# - -- --- ----- -------- -------------

proc ::coroutine::util::gets {args} {
    # Process arguments.
    # Acceptable syntax:
    # * gets CHAN ?VARNAME?

    if {[llength $args] == 2} {
	# gets CHAN VARNAME
	lassign $args chan varname
        upvar 1 $varname line
    } elseif {[llength $args] == 1} {
	# gets CHAN
	lassign $args chan
    } else {
	# not enough, or too many arguments (0, or > 2): Calling the
	# builtin gets command with the bogus arguments gives us the
	# necessary error with the proper message.
	tailcall ::chan gets {*}$args
    }

    # Loop until we have a complete line. Yield to the event loop
    # where necessary. During
    set blocking [::chan configure $chan -blocking]
    while {1} {
        ::chan configure $chan -blocking 0

	try {
	    set result [::chan gets $chan line]
	} on error {result opts} {
            ::chan configure $chan -blocking $blocking
            return -code $result -options $opts
	}

	if {[::chan blocked $chan]} {
            ::chan event $chan readable [list [info coroutine]]
            yield
            ::chan event $chan readable {}
        } else {
            ::chan configure $chan -blocking $blocking

            if {[llength $args] == 2} {
                return $result
            } else {
                return $line
            }
        }
    }
}


proc ::coroutine::util::gets_safety {chan limit varname {timeout 120000}} {
    # Process arguments.
    # Acceptable syntax:
    # * gets CHAN ?VARNAME?

    # Loop until we have a complete line. Yield to the event loop
    # where necessary. During
    set blocking [::chan configure $chan -blocking]
    upvar 1 $varname line
    try {
	while {1} {
	    ::chan configure $chan -blocking 0
	    if {[::chan pending input $chan]>= $limit} {
		error {Too many notes, Mozart. Too many notes}
	    }
	    try {
		set result [::chan gets $chan line]
	    } on error {result opts} {
		return -code $result -options $opts
	    }

	    if {[::chan blocked $chan]} {
	  set timeoutevent [::after $timeout [list [info coroutine] timeout]]
		::chan event $chan readable [list [info coroutine] readable]
		set event [yield]
		if {$event eq "timeout"} {
		  error "Connection Timed Out"
		}
		::after cancel $timeoutevent
		::chan event $chan readable {}
	    } else {
		return $result
	    }
	}
    } finally {
        ::chan configure $chan -blocking $blocking
    }
}



# - -- --- ----- -------- -------------

proc ::coroutine::util::read {args} {
    # Process arguments.
    # Acceptable syntax:
    # * read ?-nonewline ? CHAN
    # * read               CHAN ?n?

    if {[llength $args] > 2} {
	# Calling the builtin read command with the bogus arguments
	# gives us the necessary error with the proper message.
	::chan read {*}$args
	return
    }

    set total Inf ; # Number of characters to read. Here: Until eof.
    set chop  no  ; # Boolean flag. Determines if we have to trim a
    #               # \n from the end of the read string.

    if {[llength $args] == 2} {
	lassign $args a b
	if {$a eq "-nonewline"} {
	    set chan $b
	    set chop yes
	} else {
	    lassign $args chan total
	}
    } else {
	lassign $args chan
    }

    # Run the read loop. Yield to the event loop where
    # necessary. Differentiate between loop until eof, and loop until
    # n characters have been read (or eof reached).

    set buf {}

    if {$total eq "Inf"} {
	# Loop until eof.

	while 1 {
	    set blocking [::chan configure $chan -blocking]
	    ::chan configure $chan -blocking 0
	    if {[::chan eof $chan]} {
		break
	    } elseif {[::chan blocked $chan]} {
		::chan event $chan readable [list [info coroutine]]
		yield
		::chan event $chan readable {}
	    }

	    try {
		set result [::chan read $chan]
	    } on error {result opts} {
		::chan configure $chan -blocking $blocking
		return -code $result -options $opts
	    } finally {
		::chan configure $chan -blocking $blocking
	    }
	    append buf $result
	}
    } else {
	# Loop until total characters have been read, or eof found,
	# whichever is first.

	set left $total
	while 1 {
	    set blocking [::chan configure $chan -blocking]
	    ::chan configure $chan -blocking 0

	    if {[::chan eof $chan]} {
		break
	    } elseif {[::chan blocked $chan]} {
		::chan event $chan readable [list [info coroutine]]
		yield
		::chan event $chan readable {}
	    }

	    try {
		set result [::chan read $chan $left]
	    } on error {result opts} {
		::chan configure $chan -blocking $blocking
		return -code $result -options $opts
	    } finally {
		::chan configure $chan -blocking $blocking
	    }

	    append buf $result
	    incr left -[string length $result]
	    if {!$left} {
		break
	    }
	}
    }

    if {$chop && [string index $buf end] eq "\n"} {
	set buf [string range $buf 0 end-1]
    }

    return $buf
}

# - -- --- ----- -------- -------------
## This goes beyond the builtin vwait, wait for multiple variables,
## result is the name of the variable which was written.
## This code mainly by Neil Madden.

proc ::coroutine::util::await args {
    set callback [list [namespace current]::AWaitSignal [info coroutine]]

    # Step 1. Wait for a write to any of the variable, using a trace
    # to restart the coroutine, and the variable written to is
    # propagated into it.

    foreach varName $args {
        upvar 1 $varName var
        trace add variable var write $callback
    }

    set choice [yield]

    foreach varName $args {
	#checker exclude warnShadowVar
        upvar 1 $varName var
        trace remove variable var write $callback
    }

    # Step 2. To prevent the next section of the coroutine code from
    # running entirely within the variable trace (*) we now use an
    # idle handler to defer it until the trace is definitely
    # done. This trick by Peter Spjuth.
    #
    # (*) At this point we are in AWaitSignal running the coroutine.

    ::after idle [info coroutine]
    yield

    return $choice
}

proc ::coroutine::util::AWaitSignal {coroutine var index op} {
    if {$op ne "write"} { return }
    set fullvar $var
    if {$index ne ""} { append fullvar ($index) }
    $coroutine $fullvar
}

# # ## ### ##### ######## #############
## Internal (package specific) commands

proc ::coroutine::util::ID {} {
    variable counter
    return [namespace current]::C[incr counter]
}

# # ## ### ##### ######## #############
## Internal (package specific) state

namespace eval ::coroutine::util {
    #checker exclude warnShadowVar
    variable counter 0
}

# # ## ### ##### ######## #############
## Ready
package provide coroutine 1.2
return

Added modules/coroutine/coroutine_auto.pcx.















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
# -*- tcl -*- coroutine::auto.pcx
# Syntax of the commands provided by package coroutine::auto.
#
# No commands in this package. The point of the package is to overlay
# existing builtin commands with syntactically and semantically
# equivalent variants which behave propery inside and outside of
# coroutines.
#
# For use by TclDevKit's static syntax checker (v4.1+).
# See http://www.activestate.com/solutions/tcl/
# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api
# for the specification of the format of the code in this file.
#

package require pcx
pcx::register coroutine::auto
pcx::tcldep   1 needs tcl 8.6

namespace eval ::coroutine {}

# Initialization via pcx::init.
# Use a ::coroutine::init procedure for non-standard initialization.
pcx::complete

Added modules/coroutine/pkgIndex.tcl.







>
>
>
1
2
3
if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded coroutine       1.2   [list source [file join $dir coroutine.tcl]]
package ifneeded coroutine::auto 1.1.3 [list source [file join $dir coro_auto.tcl]]

Added modules/coroutine/tcllib_coroutine.man.











































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
[comment {-*- tcl -*- doctools manpage}]
[vset CORO_VERSION 1.2]
[manpage_begin coroutine n [vset CORO_VERSION]]
[keywords after]
[keywords channel]
[keywords coroutine]
[keywords events]
[keywords exit]
[keywords gets]
[keywords global]
[keywords {green threads}]
[keywords read]
[keywords threads]
[keywords update]
[keywords vwait]
[copyright {2010-2015 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
[moddesc   {Coroutine utilities}]
[category  Coroutine]
[titledesc {Coroutine based event and IO handling}]
[require Tcl 8.6]
[require coroutine [vset CORO_VERSION]]
[description]

The [package coroutine] package provides coroutine-aware
implementations of various event- and channel related commands. It can
be in multiple modes:

[list_begin enumerated]

[enum] Call the commands through their ensemble, in code which is
explicitly written for use within coroutines.

[enum] Import the commands into a namespace, either directly, or
through [cmd {namespace path}]. This allows the use from within code
which is not coroutine-aware per se and restricted to specific
namespaces.

[list_end]

A more agressive form of making code coroutine-oblivious than point 2
above is available through the package [package coroutine::auto],
which intercepts the relevant builtin commands and changes their
implementation dependending on the context they are run in, i.e.
inside or outside of a coroutine.

[section API]

All the commands listed below are synchronous with respect to the
coroutine invoking them, i.e. this coroutine blocks until the result
is available. The overall eventloop is not blocked however.

[list_begin definitions]

[call [cmd {coroutine::util after}] [arg delay]]

This command delays the coroutine invoking it by [arg delay]
milliseconds.

[call [cmd {coroutine::util await}] [arg varname]...]

This command is an extension form of the [cmd {coroutine::util vwait}]
command (see below) which waits on a write to one of many named
namespace variables.

[call [cmd {coroutine::util create}] [arg arg]...]

This command creates a new coroutine with an automatically assigned
name and causes it to run the code specified by the arguments.

[call [cmd {coroutine::util exit}] [opt [arg status]]]

This command exits the current coroutine, causing it to return
[arg status]. If no status was specified the default [arg 0] is
returned.

[call [cmd {coroutine::util gets}] [arg chan] [opt [arg varname]]]

This command reads a line from the channel [arg chan] and returns it
either as its result, or, if a [arg varname] was specified, writes it
to the named variable and returns the number of characters read.

[call [cmd {coroutine::util gets_safety}] [arg chan] [arg limit] [arg varname]]

This command reads a line from the channel [arg chan] up to size [arg limit]
and stores the result in [arg varname]. Of [arg limit] is reached before the
set first newline, an error is thrown. The command returns the number of
characters read.

[call [cmd {coroutine::util global}] [arg varname]...]

This command imports the named global variables of the coroutine into
the current scope. From the technical point of view these variables
reside in level [const #1] of the Tcl stack. I.e. these are not the
regular global variable in to the global namespace, and each coroutine
can have their own set, independent of all others.

[call [cmd {coroutine::util read}] [option -nonewline] [arg chan] [opt [arg n]]]

This command reads [arg n] characters from the channel [arg chan] and
returns them as its result. If [arg n] is not specified the command
will read the channel until EOF is reached.

[call [cmd {coroutine::util update}] [opt [const idletasks]]]

This command causes the coroutine invoking it to run pending events or
idle handlers before proceeding.

[call [cmd {coroutine::util vwait}] [arg varname]]

This command causes the coroutine calling it to wait for a write to
the named namespace variable [arg varname].

[list_end]

[vset CATEGORY coroutine]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

Added modules/cron/cron.man.





















































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
[comment {-*- tcl -*- doctools manpage}]
[vset PACKAGE_VERSION 2.1]
[manpage_begin cron n [vset PACKAGE_VERSION]]
[keywords {cron}]
[keywords {odie}]
[copyright {2016-2018 Sean Woods <yoda@etoyoc.com>}]
[moddesc   {cron}]
[titledesc {Tool for automating the period callback of commands}]
[category  System]
[require Tcl 8.6]
[require cron [opt [vset PACKAGE_VERSION]]]
[description]
[para]

The [package cron] package provides a Pure-tcl set of tools to allow
programs to schedule tasks to occur at regular intervals. Rather than
force each task to issue it's own call to the event loop, the cron
system mimics the cron utility in Unix: on task periodically checks to
see if something is to be done, and issues all commands for a given
time step at once.
[para]
Changes in version 2.0
[para]
While cron was originally designed to handle time scales > 1 second, the
latest version's internal understand time granularity down to the millisecond,
making it easier to integrate with other timed events.

Version 2.0 also understands how to properly integrate coroutines and objects.
It also adds a facility for an external (or script driven) clock. Note that vwait style events
won't work very well with an external clock.

[section Commands]
[list_begin definitions]

[call [cmd ::cron::at] [arg ?processname?] [arg timecode] [arg command]]

This command registers a [arg command] to be called at the time specified by [arg timecode].
If [arg timecode] is expressed as an integer, the timecode is assumed to be in unixtime. All
other inputs will be interpreted by [cmd {clock scan}] and converted to unix time.
This task can be modified by subsequent calls to
this package's commands by referencing [arg processname]. If [arg processname] exists,
it will be replaced.

If [arg processname] is not given, one is generated and returned by the command.

[example_begin]
::cron::at start_coffee {Tomorrow at 9:00am}  {remote::exec::coffeepot power on}
::cron::at shutdown_coffee {Tomorrow at 12:00pm}  {remote::exec::coffeepot power off}
[example_end]

[call [cmd ::cron::cancel] [arg processname]]

This command unregisters the process [arg processname] and cancels any pending commands.
Note: processname can be a process created by either [cmd ::cron::at] or [cmd ::cron::every].

[example_begin]
::cron::cancel check_mail
[example_end]

[call [cmd ::cron::every] [arg processname] [arg frequency] [arg command]]

This command registers a [arg command] to be called at the interval of [arg frequency].
[arg frequency] is given in seconds. This task can be modified by subsequent calls to
this package's commands by referencing [arg processname]. If [arg processname] exists,
it will be replaced.

[example_begin]
::cron::every check_mail 900  ::imap_client::check_mail
::cron::every backup_db  3600 {::backup_procedure ::mydb}
[example_end]

[call [cmd ::cron::in] [arg ?processname?] [arg timecode] [arg command]]

This command registers a [arg command] to be called after a delay of time specified by [arg timecode].
[arg timecode] is expressed as an seconds.
This task can be modified by subsequent calls to
this package's commands by referencing [arg processname]. If [arg processname] exists,
it will be replaced.

If [arg processname] is not given, one is generated and returned by the command.

[call [cmd ::cron::object_coroutine] [arg object] [arg coroutine] [arg ?info?]]

This command registers a [arg coroutine], associated with [arg object] to be called
given the parameters of [arg info]. If now parameters are given, the coroutine is assumed
to be an idle task which will self-terminate. [arg info] can be given in any form compadible with
[cmd {::cron::task set}]

[call [cmd ::cron::sleep] [arg milliseconds]]

When run within a coroutine, this command will register the coroutine for a callback
at the appointed time, and immediately yield.
[para]
If the ::cron::time variable is > 0 this command will advance the internal time,
100ms at a time.
[para]
In all other cases this command will generate a fictious variable, generate an
after call, and vwait the variable:
[example {
set eventid [incr ::cron::eventcount]
set var ::cron::event_#$eventid
set $var 0
::after $ms "set $var 1"
::vwait $var
::unset $var
}]
[para]
Usage:
[example_begin]
::cron::sleep 250
[example_end]

[call [cmd {::cron::task delete}] [arg process]]
Delete the process specified the [arg process]

[call [cmd {::cron::task exists}] [arg process]]
Returns true if [arg process] is registered with cron.

[call [cmd {::cron::task info}] [arg process]]
Returns a dict describing [arg process]. See [cmd {::cron::task set}] for a description of the options.

[call [cmd {::cron::task set}] [arg process] [arg field] [arg value] [arg ?field...?] [arg ?value...?]]
[para]
If [arg process] does not exist, it is created. Options Include:
[list_begin definitions]
[cmd command]
If [cmd coroutine] is black, a global command which implements this process. If [cmd coroutine] is not
black, the command to invoke to create or recreate the coroutine.
[cmd coroutine]
The name of the coroutine (if any) which implements this process.
[cmd frequency]
If -1, this process is terminated after the next event. If 0 this process should be called during every
idle event. If positive, this process should generate events periodically. The frequency is an interger number
of milleseconds between events.

[cmd object]
The object associated with this process or coroutine.
[cmd scheduled]
If non-zero, the absolute time from the epoch (in milleseconds) that this process will trigger an event.
If zero, and the [cmd frequency] is also zero, this process is called every idle loop.
[cmd running]
A boolean flag. If true it indicates the process never returned or yielded during the event loop,
and will not be called again until it does so.
[list_end]
[call [cmd ::cron::wake] [arg ?who?]]

Wake up cron, and arrange for its event loop to be run during the next Idle cycle.

[example_begin]
::cron::wake {I just did something important}
[example_end]
[list_end]
[para]
Several utility commands are provided that are used internally within cron and for
testing cron, but may or may not be useful in the general cases.
[list_begin definitions]

[call [cmd ::cron::clock_step] [arg milleseconds]]
[para]
Return a clock time absolute to the epoch which falls on the next
border between one second and the next for the value of [arg milleseconds]

[call [cmd ::cron::clock_delay] [arg milleseconds]]
[para]
Return a clock time absolute to the epoch which falls on the next
border between one second and the next [arg milleseconds] in the future.

[call [cmd ::cron::clock_sleep] [arg seconds] [arg ?offset?]]
[para]
Return a clock time absolute to the epoch which falls exactly [arg seconds] in
the future. If offset is given it may be positive or negative, and will shift
the final time to before or after the second would flip.

[call [cmd ::cron::clock_set] [arg newtime]]
[para]
Sets the internal clock for cron. This command will advance the time in 100ms
increment, triggering events, until the internal time catches up with [arg newtime].
[para]
[arg newtime] is expressed in absolute milleseconds since the beginning of the epoch.


[list_end]
[para]
[vset CATEGORY odie]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

Added modules/cron/cron.tcl.























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
###
# This file implements a process table
# Instead of having individual components try to maintain their own timers
# we centrally manage how often tasks should be kicked off here.
###
#
# Author: Sean Woods (for T&E Solutions)
package require Tcl 8.6 ;# See coroutine
package require coroutine
package require dicttool
::namespace eval ::cron {}

proc ::cron::task {command args} {
  if {$::cron::trace > 1} {
    puts [list ::cron::task $command $args]
  }
  variable processTable
  switch $command {
    TEMPLATE {
      return [list object {} lastevent 0 lastrun 0 err 0 result {} \
        running 0 coroutine {} scheduled 0 frequency 0 command {}]
    }
    delete {
      unset -nocomplain ::cron::processTable([lindex $args 0])
    }
    exists {
      return [::info exists ::cron::processTable([lindex $args 0])]
    }
    info {
      set process [lindex $args 0]
      if {![::info exists ::cron::processTable($process)]} {
        error "Process $process does not exist"
      }
      return $::cron::processTable($process)
    }
    frequency {
      set process [lindex $args 0]
      set time [lindex $args 1]
      if {![info exists ::cron::processTable($process)]} return
      dict with ::cron::processTable($process) {
        set now [clock_step [current_time]]
        set frequency [expr {0+$time}]
        if {$scheduled>($now+$time)} {
          dict set ::cron::processTable($process) scheduled [expr {$now+$time}]
        }
      }
    }
    sleep {
      set process [lindex $args 0]
      set time [lindex $args 1]
      if {![info exists ::cron::processTable($process)]} return
      dict with ::cron::processTable($process) {
        set now [clock_step [current_time]]
        set frequency 0
        set scheduled [expr {$now+$time}]
      }
    }
    create -
    set {
      set process [lindex $args 0]
      if {![::info exists ::cron::processTable($process)]} {
        set ::cron::processTable($process) [task TEMPLATE]
      }
      if {[llength $args]==2} {
        foreach {field value} [lindex $args 1] {
          dict set ::cron::processTable($process) $field $value
        }
      } else {
        foreach {field value} [lrange $args 1 end] {
          dict set ::cron::processTable($process) $field $value
        }
      }
    }
  }
}

proc ::cron::at args {
  if {$::cron::trace > 1} {
    puts [list ::cron::at $args]
  }
  switch [llength $args] {
    2 {
      variable processuid
      set process event#[incr processuid]
      lassign $args timecode command
    }
    3 {
      lassign $args process timecode command
    }
    default {
      error "Usage: ?process? timecode command"
    }
  }
  variable processTable
  if {[string is integer -strict $timecode]} {
    set scheduled [expr {$timecode*1000}]
  } else {
    set scheduled [expr {[clock scan $timecode]*1000}]
  }
  ::cron::task set $process \
    frequency -1 \
    command $command \
    scheduled $scheduled \
    coroutine {}

  if {$::cron::trace > 1} {
    puts [list ::cron::task info $process - > [::cron::task info $process]]
  }
  ::cron::wake NEW
  return $process
}

proc ::cron::idle args {
  if {$::cron::trace > 1} {
    puts [list ::cron::idle $args]
  }
  switch [llength $args] {
    2 {
      variable processuid
      set process event#[incr processuid]
      lassign $args command
    }
    3 {
      lassign $args process command
    }
    default {
      error "Usage: ?process? timecode command"
    }
  }
  ::cron::task set $process \
    scheduled 0 \
    frequency 0 \
    command $command
  ::cron::wake NEW
  return $process
}

proc ::cron::in args {
  if {$::cron::trace > 1} {
    puts [list ::cron::in $args]
  }
  switch [llength $args] {
    2 {
      variable processuid
      set process event#[incr processuid]
      lassign $args timecode command
    }
    3 {
      lassign $args process timecode command
    }
    default {
      error "Usage: ?process? timecode command"
    }
  }
  set now [clock_step [current_time]]
  set scheduled [expr {$timecode*1000+$now}]
  ::cron::task set $process \
    frequency -1 \
    command $command \
    scheduled $scheduled
  ::cron::wake NEW
  return $process
}

proc ::cron::cancel {process} {
  if {$::cron::trace > 1} {
    puts [list ::cron::cancel $process]
  }
  ::cron::task delete $process
}

###
# topic: 0776dccd7e84530fa6412e507c02487c
###
proc ::cron::every {process frequency command} {
  if {$::cron::trace > 1} {
    puts [list ::cron::every $process $frequency $command]
  }
  variable processTable
  set mnow [clock_step [current_time]]
  set frequency [expr {$frequency*1000}]
  ::cron::task set $process \
    frequency $frequency \
    command $command \
    scheduled [expr {$mnow + $frequency}]
  ::cron::wake NEW
}


proc ::cron::object_coroutine {objname coroutine {info {}}} {
  if {$::cron::trace > 1} {
    puts [list ::cron::object_coroutine $objname $coroutine $info]
  }
  task set $coroutine \
    {*}$info \
    object $objname \
    coroutine $coroutine

  return $coroutine
}

# Notification that an object has been destroyed, and that
# it should give up any toys associated with events
proc ::cron::object_destroy {objname} {
  if {$::cron::trace > 1} {
    puts [list ::cron::object_destroy $objname]
  }
  variable processTable
  set dat [array get processTable]
  foreach {process info} $dat {
    if {[dict exists $info object] && [dict get $info object] eq $objname} {
      unset -nocomplain processTable($process)
    }
  }
}

###
# topic: 97015814408714af539f35856f85bce6
###
proc ::cron::run process {
  variable processTable
  set mnow [clock_step [current_time]]
  if {[dict exists processTable($process) scheduled] && [dict exists processTable($process) scheduled]>0} {
    dict set processTable($process) scheduled [expr {$mnow-1000}]
  } else {
    dict set processTable($process) lastrun 0
  }
  ::cron::wake PROCESS
}

proc ::cron::clock_step timecode {
  return [expr {$timecode-($timecode%1000)}]
}

proc ::cron::clock_delay {delay} {
  set now [current_time]
  set then [clock_step [expr {$delay+$now}]]
  return [expr {$then-$now}]
}

# Sleep for X seconds, wake up at the top
proc ::cron::clock_sleep {{sec 1} {offset 0}} {
  set now [current_time]
  set delay [expr {[clock_delay [expr {$sec*1000}]]+$offset}]
  sleep $delay
}

proc ::cron::current_time {} {
  if {$::cron::time < 0} {
    return [clock milliseconds]
  }
  return $::cron::time
}

proc ::cron::clock_set newtime {
  variable time
  for {} {$time < $newtime} {incr time 100} {
    uplevel #0 {::cron::do_one_event CLOCK_ADVANCE}
  }
  set time $newtime
  uplevel #0 {::cron::do_one_event CLOCK_ADVANCE}
}

proc ::cron::once_in_a_while body {
  set script {set _eventid_ $::cron::current_event}
  append script $body
  # Add a safety to allow this while to only execute once per call
  append script {if {$_eventid_==$::cron::current_event} yield}
  uplevel 1 [list while 1 $script]
}

proc ::cron::sleep ms {
  if {$::cron::trace > 1} {
    puts [list ::cron::sleep $ms [info coroutine]]
  }

  set coro [info coroutine]
  # When the clock is being externally
  # controlled, advance the clock when
  # a sleep is called
  variable time
  if {$time >= 0 && $coro eq {}} {
    ::cron::clock_set [expr {$time+$ms}]
    return
  }
  if {$coro ne {}} {
    set mnow [current_time]
    set start $mnow
    set end [expr {$start+$ms}]
    set eventid $coro
    if {$::cron::trace} {
      puts "::cron::sleep $ms $coro"
    }
    # Mark as running
    task set $eventid scheduled $end coroutine $coro running 1
    ::cron::wake WAKE_IN_CORO
    yield 2
    while {$end >= $mnow} {
      if {$::cron::trace} {
        puts "::cron::sleep $ms $coro (loop)"
      }
      set mnow [current_time]
      yield 2
    }
    # Mark as not running to resume idle computation
    task set $eventid running 0
    if {$::cron::trace} {
      puts "/::cron::sleep $ms $coro"
    }
  } else {
    set eventid [incr ::cron::eventcount]
    set var ::cron::event_#$eventid
    set $var 0
    if {$::cron::trace} {
      puts "::cron::sleep $ms $eventid waiting for $var"
      ::after $ms "set $var 1 ; puts \"::cron::sleep - $eventid - FIRED\""
    } else {
      ::after $ms "set $var 1"
    }
    ::vwait $var
    if {$::cron::trace} {
      puts "/::cron::sleep $ms $eventid"
    }
    unset $var
  }
}

###
# topic: 21de7bb8db019f3a2fd5a6ae9b38fd55
# description:
#    Called once per second, and timed to ensure
#    we run in roughly realtime
###
proc ::cron::runTasksCoro {} {
  ###
  # Do this forever
  ###
  variable processTable
  variable processing
  variable all_coroutines
  variable coroutine_object
  variable coroutine_busy
  variable nextevent
  variable current_event

  while 1 {
    incr current_event
    set lastevent 0
    set now [current_time]
    # Wake me up in 5 minute intervals, just out of principle
    set nextevent [expr {$now-($now % 300000) + 300000}]
    set next_idle_event [expr {$now+250}]
    if {$::cron::trace > 1} {
      puts [list CRON TASK RUNNER nextevent $nextevent]
    }
    ###
    # Determine what tasks to run this timestep
    ###
    set tasks {}
    set cancellist {}
    set nexttask {}

    foreach {process} [lsort -dictionary [array names processTable]] {
      dict with processTable($process) {
        if {$::cron::trace > 1} {
          puts [list CRON TASK RUNNER process $process frequency: $frequency scheduled: $scheduled]
        }
        if {$scheduled==0 && $frequency==0} {
          set lastrun $now
          set lastevent $now
          lappend tasks $process
        } else {
          if { $scheduled <= $now } {
            lappend tasks $process
            if { $frequency < 0 } {
              lappend cancellist $process
            } elseif {$frequency==0} {
              set scheduled 0
              if {$::cron::trace > 1} {
                puts [list CRON TASK RUNNER process $process demoted to idle]
              }
            } else {
              set scheduled [clock_step [expr {$frequency+$lastrun}]]
              if { $scheduled <= $now } {
                set scheduled [clock_step [expr {$frequency+$now}]]
              }
              if {$::cron::trace > 1} {
                puts [list CRON TASK RUNNER process $process rescheduled to $scheduled]
              }
            }
            set lastrun $now
          }
          set lastevent $now
        }
      }
    }
    foreach task $tasks {
      dict set processTable($task) lastrun $now
      if {[dict exists processTable($task) foreground] && [dict set processTable($task) foreground]} continue
      if {[dict exists processTable($task) running] && [dict set processTable($task) running]} continue
      if {$::cron::trace > 2} {
        puts [list RUNNING $task [task info $task]]
      }
      set coro [dict getnull $processTable($task) coroutine]
      dict set processTable($task) running 1
      set command [dict getnull $processTable($task) command]
      if {$command eq {} && $coro eq {}} {
        # Task has nothing to do. Slot it for destruction
        lappend cancellist $task
      } elseif {$coro ne {}} {
        if {[info command $coro] eq {}} {
          set object [dict get $processTable($task) object]
          # Trigger coroutine again if a command was given
          # If this coroutine is associated with an object, ensure
          # the object still exists before invoking its method
          if {$command eq {} || ($object ne {} && [info command $object] eq {})} {
            lappend cancellist $task
            dict set processTable($task) running 0
            continue
          }
          if {$::cron::trace} {
            puts [list RESTARTING $task - coroutine $coro - with $command]
          }
          ::coroutine $coro {*}$command
        }
        try $coro on return {} {
          # Terminate the coroutine
          lappend cancellist $task
        } on break {} {
          # Terminate the coroutine
          lappend cancellist $task
        } on error {errtxt errdat} {
          # Coroutine encountered an error
          lappend cancellist $task
          puts "ERROR $coro"
          set errorinfo [dict get $errdat -errorinfo]
          if {[info exists coroutine_object($coro)] && $coroutine_object($coro) ne {}} {
            catch {
            puts "OBJECT: $coroutine_object($coro)"
            puts "CLASS: [info object class $coroutine_object($coro)]"
            }
          }
          puts "$errtxt"
          puts ***
          puts $errorinfo
        } on continue {result opts} {
          # Ignore continue
          if { $result eq "done" } {
            lappend cancellist $task
          }
        } on ok {result opts} {
          if { $result eq "done" } {
            lappend cancellist $task
          }
        }
      } else {
        dict with processTable($task) {
          set err [catch {uplevel #0 $command} result errdat]
          if $err {
            puts "CRON TASK FAILURE:"
            puts "PROCESS: $task"
            puts $result
            puts ***
            puts [dict get $errdat -errorinfo]
          }
        }
        yield 0
      }
      dict set processTable($task) running 0
    }
    foreach {task} $cancellist {
      unset -nocomplain processTable($task)
    }
    foreach {process} [lsort -dictionary [array names processTable]] {
      set scheduled 0
      set frequency 0
      dict with processTable($process) {
        if {$scheduled==0 && $frequency==0} {
          if {$next_idle_event < $nextevent} {
            set nexttask $task
            set nextevent $next_idle_event
          }
        } elseif {$scheduled < $nextevent} {
          set nexttask $process
          set nextevent $scheduled
        }
        set lastevent $now
      }
    }
    foreach {eventid msec} [array get ::cron::coro_sleep] {
      if {$msec < 0} continue
      if {$msec<$nextevent} {
        set nexttask "CORO $eventid"
        set nextevent $scheduled
      }
    }
    set delay [expr {$nextevent-$now}]
    if {$delay <= 0} {
      yield 0
    } else {
      if {$::cron::trace > 1} {
        puts "NEXT EVENT $delay - NEXT TASK $nexttask"
      }
      yield $delay
    }
  }
}

proc ::cron::wake {{who ???}} {
  ##
  # Only triggered by cron jobs kicking off other cron jobs within
  # the script body
  ##
  if {$::cron::trace} {
    puts "::cron::wake $who"
  }
  if {$::cron::busy} {
    return
  }
  after cancel $::cron::next_event
  set ::cron::next_event [after idle [list ::cron::do_one_event $who]]
}

proc ::cron::do_one_event {{who ???}} {
  if {$::cron::trace} {
    puts "::cron::do_one_event $who"
  }
  after cancel $::cron::next_event
  set now [current_time]
  set ::cron::busy 1
  while {$::cron::busy} {
    if {[info command ::cron::COROUTINE] eq {}} {
      ::coroutine ::cron::COROUTINE ::cron::runTasksCoro
    }
    set cron_delay [::cron::COROUTINE]
    if {$cron_delay==0} {
      if {[incr loops]>10} {
        if {$::cron::trace} {
          puts "Breaking out of 10 recursive loops"
        }
        set ::cron::wake_time 1000
        break
      }
      set ::cron::wake_time 0
      incr ::cron::loops(active)
    } else {
      set ::cron::busy 0
      incr ::cron::loops(idle)
    }
  }
  ###
  # Try to get the event to fire off on the border of the
  # nearest second
  ###
  if {$cron_delay < 10} {
    set cron_delay 250
  }
  set ctime [current_time]
  set next [expr {$ctime+$cron_delay}]
  set ::cron::wake_time [expr {$next/1000}]
  if {$::cron::trace} {
    puts [list EVENT LOOP WILL WAKE IN $cron_delay ms next: [clock format $::cron::wake_time -format "%H:%M:%S"] active: $::cron::loops(active) idle: $::cron::loops(idle) woken_by: $who]
  }
  set ::cron::next_event [after $cron_delay {::cron::do_one_event TIMER}]
}


proc ::cron::main {} {
  # Never launch from a coroutine
  if {[info coroutine] ne {}} {
    return
  }
  set ::cron::forever 1
  while {$::cron::forever} {
    ::after 120000 {set ::cron::forever 1}
    # Call an update just to give the rest of the event loop a chance
    incr ::cron::loops(main)
    ::after cancel $::cron::next_event
    set ::cron::next_event [::after idle {::cron::wake MAIN}]
    set ::cron::forever 1
    set ::cron::busy 0
    ::vwait ::cron::forever
    if {$::cron::trace} {
      puts "MAIN LOOP CYCLE $::cron::loops(main)"
    }
  }
}

###
# topic: 4a891d0caabc6e25fbec9514ea8104dd
# description:
#    This file implements a process table
#    Instead of having individual components try to maintain their own timers
#    we centrally manage how often tasks should be kicked off here.
###
namespace eval ::cron {
  variable lastcall 0
  variable processTable
  variable busy 0
  variable next_event {}
  variable trace 0
  variable current_event
  variable time -1
  if {![info exists current_event]} {
    set current_event 0
  }
  if {![info exists ::cron::loops]} {
    array set ::cron::loops {
      active 0
      main 0
      idle 0
      wake 0
    }
  }
}

::cron::wake STARTUP
package provide cron 2.1

Added modules/cron/cron.test.



























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
# Tests for the cron module
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2016 by Sean Woods
# (Insert BSDish style "use at your own risk" license text)

source [file join \
    [file dirname [file dirname [file join [pwd] [info script]]]] \
    devtools testutilities.tcl]

package require tcltest
testsNeedTcl     8.6
testsNeedTcltest 1.0

support {
    use dicttool/dicttool.tcl   dicttool
}
testing {
    useLocal cron.tcl cron
}

###
# For the first part of our testing, control the clock
# via the test harness
###
set ::cron::trace 0
set ::cron::time [expr {[clock scan {2016-01-01}]*1000}]

foreach {val testval} {
  1000 1000
  11235 11000
  1241241 1241000
} {
  test cron-step-$val [list test clock_step function for $val] {
    ::cron::clock_step $val
  } $testval 
}

proc test_elapsed_time {start target} {
  set now [::cron::current_time]
  set value [expr {$now-$start}]
  if {$value < ($target-5)} {
    puts "ELAPSED TIME WAS SHORT: $value / $target"
    return 1
  }
  if {$value > ($target+250)} {
    puts "ELAPSED TIME WAS LONG: $value / $target"
    return 1
  }
  return 0
}


set start [::cron::current_time]
::cron::sleep 250
test cron-sleep-1 {Ensure sleep is in a plausible range} {
  test_elapsed_time $start 250
} 0

# Sleep until the top of the second
::cron::clock_sleep 1
set start [::cron::current_time]
::cron::clock_sleep 0 750
test cron-sleep-2 {Ensure sleep is in a plausible range} {
  test_elapsed_time $start 750
} 0
::cron::clock_sleep 1 0
test cron-sleep-3 {Ensure sleep is in a plausible range} {
  test_elapsed_time $start 1000
} 0
::cron::clock_sleep 1 0

###
# Object interaction tests
###
oo::class create CronTest {

  method coro_name {} {
    return [info object namespace [self]]::idle
  }
  method idle {} {
    set coro [my coro_name]
    ::cron::object_coroutine [self] $coro
    ::coroutine $coro {*}[namespace code {my IdleTask}]
  }

}

###
# This test is a mockup of typical Tk widget
# which has some portion of its startup that has to
# process after an idle loop has completed
###
oo::class create CronTest_3Pings {
  superclass CronTest
  constructor {} {
    set ::TESTOBJ([self]) 0
    my idle
  }
  method IdleTask {} {
    incr ::TESTOBJ([self])
    yield
    incr ::TESTOBJ([self])
    yield
    incr ::TESTOBJ([self])
  }
}
CronTest_3Pings create FOO
set coro [FOO coro_name]
###
# The coroutine for the object exist on startup
test cron-objects-1-1 {cron::every} {
  info commands $coro
} $coro
# And CRON knows about it
test cron-objects-1-2 {cron::every} {
  ::cron::task exists $coro
} 1
# The counter should be initialized to the value
# before the first yield
test cron-objects-1-3 {cron::every} {
  set ::TESTOBJ(::FOO)
} 1
::cron::clock_sleep 1

###
# The coroutine should have completed, and now ceases to exist
###
test cron-objects-1-4 {cron::every} {
  ::cron::task exists $coro
} 0
# The counter should be 3
test cron-objects-1-5 {cron::every} {
  set ::TESTOBJ(::FOO)
} 3

###
# Test that cron cleans up after a destroyed object
###
CronTest_3Pings create FOOBAR
set coro [FOOBAR coro_name]
###
# The coroutine for the object exist on startup
test cron-objects-2-1 {cron::every} {
  info commands $coro
} $coro
# However CRON knows about it
test cron-objects-2-2 {cron::every} {
  ::cron::task exists $coro
} 1
FOOBAR destroy

# The idle routine did parse up to the first yield
test cron-objects-2-3 {cron::every} {
  set ::TESTOBJ(::FOOBAR)
} 1

###
# The coroutine for the object exist on startup
test cron-objects-2-4 {cron::every} {
  info commands $coro
} {}
# However CRON knows about it
test cron-objects-2-5 {cron::every} {
  ::cron::task exists $coro
} 1

# Trigger the idle loop
::cron::do_one_event TEST
# The idle routine did parse up to the first yield
test cron-objects-2-6 {cron::every} {
  set ::TESTOBJ(::FOOBAR)
} 1
# The coroutine is still gone
test cron-objects-2-7 {cron::every} {
  info commands $coro
} {}
# And now cron has forgotten about the object
test cron-objects-2-8 {cron::every} {
  ::cron::task exists $coro
} 0

::cron::do_one_event TEST
test cron-objects-2-9 {cron::every} {
  info commands $coro
} {}
# However cron has forgotten about the object
test cron-objects-2-10 {cron::every} {
  ::cron::task exists $coro
} 0


oo::class create CronTest_Persistant_Coro {
  superclass CronTest
  constructor {} {
    set nspace [info object namespace [self]]
    set coro_do [my coro_name DoLoop]
    set ::TESTOBJ([self]) -1
    set now [::cron::current_time]
    set frequency 1000
    set scheduled [::cron::clock_step [expr {$now+$frequency}]]
    ::cron::object_coroutine [self] $coro_do [list frequency $frequency scheduled $scheduled command [namespace code {my DoLoop}]]
  }
  method coro_name {which} {
    return [info object namespace [self]]::${which}
  }
  method exit_loop {} {
    my variable doloop
    set doloop 0
    if {$::cron::trace} {
      puts [list [self] SIGNAL TO EXIT]
    }
  }
  
  method DoLoop {} {
    if {$::cron::trace} {
      puts "[self] CORO START"
    }
    my variable doloop
    set doloop 1
    set ::TESTOBJ([self]) 0
    yield
    while {$doloop} {
      if {$::cron::trace} {
        puts [list [self] LOOP $doloop]
      }
      incr ::TESTOBJ([self])
      yield
    }
    if {$::cron::trace} {
      puts "[self] CORO EXIT"
    }
  }
}

###
# This series of tests is built around a more complex case:
# an object wants a method invoked periodically. CRON
# will create a coroutine (based on the name given by the object)
# and invoke that coroutine at the frequency requested
#
# If the coroutine exits (or throws an error) It will be restarted
###
set ::cron::trace 0
::cron::clock_sleep 1

CronTest_Persistant_Coro create IRONBAR
set coro [IRONBAR coro_name DoLoop]
test cron-objects-3-1 {
The actual coroutine should not exist yet
} {
  info commands $coro
} {}
# And CRON knows about it
test cron-objects-3-2 {
CRON should be aware of the task
} {
  ::cron::task exists $coro
} 1

test cron-objects-3-3 {
The counter should be initialized to the value
before the first yield
} {
  set ::TESTOBJ(::IRONBAR)
} -1

set start [::cron::current_time]
::cron::clock_sleep 1

test cron-objects-3-4 {The coroutine for the object exists} {
  info commands $coro
} $coro
test cron-objects-3-5 {Cron should know about the task} {
  ::cron::task exists $coro
} 1
test cron-objects-3-6 {The counter should have incremented} {
  set ::TESTOBJ(::IRONBAR)
} 1

::cron::clock_sleep 0 500
test cron-objects-3-7 {The counter should have incremented} {
  set ::TESTOBJ(::IRONBAR)
} 1
::cron::clock_sleep 1

# Test a graceful exit of the coroutine
::IRONBAR exit_loop
::cron::clock_sleep 1
set coro [IRONBAR coro_name DoLoop]
test cron-objects-3-8 {
The actual coroutine should now exit
} {
  info commands $coro
} {}
test cron-objects-3-9 {
CRON should still be aware of the tast
} {
  ::cron::task exists $coro
} 1
test cron-objects-3-10 {The counter hasn't reset} {
  set ::TESTOBJ(::IRONBAR)
} 2
::cron::clock_sleep 1
test cron-objects-3-11 {The should have reset when the coroutine restarted} {
  set ::TESTOBJ(::IRONBAR)
} 1
#::cron::object_destroy ::IRONBAR
::IRONBAR destroy

set ::cron::trace 0
proc my_coro {} {
  if {$::cron::trace} {
    puts "START MY CORO"
  }
  set ::my_coro_progress 0
  set ::my_coro_start [::cron::current_time]
  if {$::cron::trace} {
    puts "SLEEP MY CORO"
  }
  ::cron::sleep 1250
  if {$::cron::trace} {
    puts "/SLEEP MY CORO"
  }
  set ::my_coro_end [::cron::current_time]
  set ::my_coro_progress 1
  if {$::cron::trace} {
    puts "END MY CORO"
  }
}

###
# Test that an otherwise inprepared coroutine
# which invokes "::cron::sleep" partipates in
# the ::cron event system
###
if {$::cron::trace} {
  puts "PRE-MY CORO"
}
coroutine ::TESTCORO my_coro
if {$::cron::trace} {
  puts "POST-MY CORO"
}
test cron-naive-corotine-1 {cron::coroutine sleep} {
  set ::my_coro_progress
} 0
::cron::clock_sleep 3
set ::cron::trace 0

test cron-naive-corotine-2 {cron::coroutine sleep} {
  set ::my_coro_progress
} 1

test cron-naive-corotine-3 {cron::coroutine sleep} {
  set delay [expr {($::my_coro_end - $::my_coro_start)}]
  if {$delay < 1000 || $delay > 2000} {
    puts "TIME DELAY OUT OF RANGE: $delay"
    return 1
  } else {
    return 0
  }
  
} 0

###
# Tests after this point test interactions with the Tcl event loop
# We need to be slaved to the real time clock to work properly
###
set ::cron::trace 0
set ::cron::time -1

###
# Test the clock sleep offset feature
###
# Reset to the top of a clock step
::cron::clock_sleep 1

set ::cron::trace 0
set start [::cron::current_time]
set ::FLAG -1
set time_0 [::cron::clock_delay 1000]
set time_1 [::cron::clock_delay 2000]

after $time_0 {set ::FLAG 0}
after $time_1 {set ::FLAG 1}
test cron-delay-1 {Prior to the first event the value should not have changed} {
  set ::FLAG
} -1

vwait ::FLAG
test cron-delay-3 {At the top of the second, we should have a new value for flag} {
  set ::FLAG
} 0
vwait ::FLAG
test cron-delay-5 {At the top of the second second, we should have a new value for flag} {
  set ::FLAG
} 1
set ::cron::trace 0

proc elapsed_time_coro {} {
  set ::start [::cron::current_time]
  while 1 {
    set now [::cron::current_time]
    set ::elapsed_time [expr {($now-$::start)/1000}]
    yield
  }
}

::cron::task set ::ELAPSED_TIME \
  coroutine ::ELAPSED_TIME \
  command elapsed_time_coro \
  frequency 1000

set timecounter 0
::cron::every timecounter 1 {incr timecounter}
set now [clock seconds]

# Test at
set timerevent 0
::cron::at timeevent1 [expr {$now + 5}] {set ::timerevent 1}
::cron::at timeevent2 [expr {$now + 6}] {set ::eventpause 0}
::cron::at timeevent3 [expr {$now + 10}] {set ::timerevent 2}
::cron::at timeevent4 [expr {$now + 11}] {set ::pause 0}

test cron-1.1 {cron::every} {
  set ::timecounter
} 0
test cron-1.2 {cron::at1} {
  set ::timerevent
} 0
vwait eventpause
test cron-1.3 {cron::at1} {
  set ::timerevent
} 1


###
# At this point 6 seconds should have passed
###
#test cron-1.elapsed-1 {Elapsed time} {
#  set ::elapsed_time
#} 5
# - Test removed - Was too unstable on a busy computer

vwait pause
###
# At this point 11 seconds should have passed
###
#test cron-1.elapsed-2 {Elapsed time} {
#  set ::elapsed_time
#} 10
# - Test removed - Was too unstable on a busy computer

# Test that in X seconds our timer
# was incremented X times
#test cron-1.4 {cron::every} {
#  set ::timecounter
#} $::elapsed_time
#
# - Test removed - Was too unstable on a busy computer

test cron-1.5 {cron::at2} {
  set ::timerevent
} 2

###
# Confirm cancel works
::cron::cancel timecounter
set timecounterfinal $::timecounter
::cron::clock_sleep 2
test cron-1.6 {cron::cancel} {
  set ::timecounter
} $::timecounterfinal

###
# Test the new IN command
###
set ::inevent 0
cron::in 5 {set ::inevent 1}

test cron-1.7 {cron::in} {
  set ::inevent
} 0
::cron::clock_sleep 6

test cron-1.8 {cron::in} {
  set ::inevent
} 1


set FAILED 0
after 10000 {set ::cron::forever 0 ; set FAILED 1}
::cron::in 5 {
  set ::cron::forever 0
test cron-1.12 {cron::main} {
  set ::cron::forever
} 0
}
::cron::wake TEST

###
# At this point 22 seconds should have passed
###
#test cron-1.elapsed-3 {Elapsed time} {
#  set ::elapsed_time
#} 21
#
# Test removed - it was too unstable on a real working computer

::cron::main

# If we get to this test, mission successful
test cron-1.13 {cron::main} {
  return 1
} 1

test cron-1.14 {cron::main} {
  set FAILED
} 0

testsuiteCleanup
return

Added modules/cron/pkgIndex.tcl.





>
>
1
2
if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded cron 2.1 [list source [file join $dir cron.tcl]]

Added modules/dicttool/dicttool.man.

























































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin dicttool n 1.0]
[keywords dict]
[copyright {2017 Sean Woods <yoda@etoyoc.com>}]
[moddesc   {Extensions to the standard "dict" command}]
[category Utilites]
[titledesc {Dictionary Tools}]
[require Tcl 8.5]
[description]
[para]
The [package dicttool] package enhances the standard [emph dict] command with several new
commands. In addition, the package also defines several "creature comfort" list commands as well.
Each command checks to see if a command already exists of the same name before adding itself,
just in case any of these slip into the core.

[list_begin definitions]
[call [cmd ladd] [arg varname] [arg args]]

This command will add a new instance of each element in [arg args] to [arg varname], but only if that element
is not already present.

[call [cmd ldelete] [arg varname] [arg args]]

This command will add a delete all instances of each element in [arg args] from [arg varname].

[call [cmd {dict getnull}] [arg args]]

Operates like [cmd {dict get}], however if the key [arg args] does not exist, it returns an empty
list instead of throwing an error.

[call [cmd {dict print}] [arg dict]]

This command will produce a string representation of [arg dict], with each nested branch on
a newline, and indented with two spaces for every level.

[call [cmd {dict is_dict}] [arg value]]

This command will return true if [arg value] can be interpreted as a dict. The command operates in
such a way as to not force an existing dict representation to shimmer into another internal rep.

[call [cmd rmerge] [arg args]]

Return a dict which is the product of a recursive merge of all of the arguments. Unlike [cmd {dict merge}],
this command descends into all of the levels of a dict. Dict keys which end in a : indicate a leaf, which
will be interpreted as a literal value, and not descended into further.

[example {

set items [dict merge {
  option {color {default: green}}
} {
  option {fruit {default: mango}}
} {
  option {color {default: blue} fruit {widget: select values: {mango apple cherry grape}}}
}]
puts [dict print $items]
}]

Prints the following result:
[example {
option {
  color {
    default: blue
  }
  fruit {
    widget: select
    values: {mango apple cherry grape}
  }
}
}]

[list_end]

[vset CATEGORY dict]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

Added modules/dicttool/dicttool.md.





























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
The dicttool Package
====================

The **dicttool** package enhances the standard *dict* command with several new
commands. In addition, the package also defines several "creature comfort" list commands as well.
Each command checks to see if a command already exists of the same name before adding itself,
just in case any of these slip into the core.

#### ladd *varname* *args*

This command will add a new instance of each element in *args* to *varname*,
but only if that element is not already present.

#### ldelete] *varname* *args*

This command will add a delete all instances of each element in *args* from *varname*.

#### dict getnull *args*

Operates like **dict get**, however if the key *args* does not exist, it returns an empty
list instead of throwing an error.

#### dict print *dict*

This command will produce a string representation of *dict*, with each nested branch on
a newline, and indented with two spaces for every level.

#### dict is_dict *value*

This command will return true if *value* can be interpreted as a dict. The command operates in
such a way as to not force an existing dict representation to shimmer into another internal rep.

#### dict rmerge *args*

Return a dict which is the product of a recursive merge of all of the arguments. Unlike **dict merge**,
this command descends into all of the levels of a dict. Dict keys which end in a : indicate a leaf, which
will be interpreted as a literal value, and not descended into further.

<pre><code>
set items [dict merge {
  option {color {default: green}}
} {
  option {fruit {default: mango}}
} {
  option {color {default: blue} fruit {widget: select values: {mango apple cherry grape}}}
}]
puts [dict print $items]
</code></pre>


Prints the following result:
<pre><code>
option {
  color {
    default: blue
  }
  fruit {
    widget: select
    values: {mango apple cherry grape}
  }
}
</pre></code>

Added modules/dicttool/dicttool.tcl.























































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
###
# This package enhances the stock dict implementation with some
# creature comforts
###
if {[info commands ::ladd] eq {}} {
  proc ladd {varname args} {
    upvar 1 $varname var
    if ![info exists var] {
        set var {}
    }
    foreach item $args {
      if {$item in $var} continue
      lappend var $item
    }
    return $var
  }
}

if {[info command ::ldelete] eq {}} {
  proc ::ldelete {varname args} {
    upvar 1 $varname var
    if ![info exists var] {
        return
    }
    foreach item [lsort -unique $args] {
      while {[set i [lsearch $var $item]]>=0} {
        set var [lreplace $var $i $i]
      }
    }
    return $var
  }  
}

if {[::info commands ::tcl::dict::getnull] eq {}} {
  proc ::tcl::dict::getnull {dictionary args} {
    if {[exists $dictionary {*}$args]} {
      get $dictionary {*}$args
    }
  }
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] getnull ::tcl::dict::getnull]
}
if {[::info commands ::tcl::dict::print] eq {}} {
  ###
  # Test if element is a dict
  ###
  proc ::tcl::dict::_putb {buffervar indent field value} {
    ::upvar 1 $buffervar buffer
    ::append buffer \n [::string repeat " " $indent] [::list $field] " "
    if {[string index $field end] eq "/"} {
      ::incr indent 2
      ::append buffer "\{"
      foreach item $value {
        if [catch {
        if {![is_dict $item]} {
          ::append buffer \n [::string repeat " " $indent] [list $item]
        } else {
          ::append buffer \n "[::string repeat " " $indent]\{"
          ::incr indent 2
          foreach {sf sv} $item {
            _putb buffer $indent $sf $sv
          }
          ::incr indent -2
          ::append buffer \n "[::string repeat " " $indent]\}"          
        }
        } err] {
          puts [list FAILED $indent $field $item]
          puts $err
          puts "$::errorInfo"
        }
      }
      ::incr indent -2
      ::append buffer \n [::string repeat " " $indent] "\}"
    } elseif {[string index $field end] eq ":" || ![is_dict $value]} {
      ::append buffer [::list $value]
    } else {
      ::incr indent 2
      ::append buffer "\{"
      foreach {f v} $value {
        _putb buffer $indent $f $v
      }
      ::incr indent -2
      ::append buffer \n [::string repeat " " $indent] "\}"
    }
  }
  proc ::tcl::dict::print dict {
    ::set buffer {}
    ::foreach {field value} $dict {
      _putb buffer 0 $field $value
    }
    return $buffer
  }
  
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] print ::tcl::dict::print]
}
if {[::info commands ::tcl::dict::is_dict] eq {}} {
  ###
  # Test if element is a dict
  ###
  proc ::tcl::dict::is_dict { d } {
    # is it a dict, or can it be treated like one?
    if {[catch {dict size $d} err]} {
      #::set ::errorInfo {}
      return 0
    }
    return 1
  }
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] is_dict ::tcl::dict::is_dict]
}
if {[::info commands ::tcl::dict::rmerge] eq {}} {
  ###
  # title: A recursive form of dict merge
  # description:
  # A routine to recursively dig through dicts and merge
  # adapted from http://stevehavelka.com/tcl-dict-operation-nested-merge/
  ###
  proc ::tcl::dict::rmerge {a args} {
    ::set result $a
    # Merge b into a, and handle nested dicts appropriately
    ::foreach b $args {
      for { k v } $b {
        if {[string index $k end] eq ":"} {
          # Element names that end in ":" are assumed to be literals
          set result $k $v
        } elseif { [dict exists $result $k] } {
          # key exists in a and b?  let's see if both values are dicts
          # both are dicts, so merge the dicts
          if { [is_dict [get $result $k]] && [is_dict $v] } {
            set result $k [rmerge [get $result $k] $v]
          } else {  
            set result $k $v
          }
        } else {
          set result $k $v
        }
      }
    }
    return $result
  }
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] rmerge ::tcl::dict::rmerge]
}

if {[::info commands ::tcl::dict::isnull] eq {}} {
  proc ::tcl::dict::isnull {dictionary args} {
    if {![exists $dictionary {*}$args]} {return 1}
    return [expr {[get $dictionary {*}$args] in {{} NULL null}}]
  }
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] isnull ::tcl::dict::isnull]
}

package provide dicttool 1.1

Added modules/dicttool/pkgIndex.tcl.























>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded dicttool 1.1 [list source [file join $dir dicttool.tcl]]

Added modules/oodialect/oodialect.demo.





























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
set here [file dirname [file join [pwd] [info script]]]
set auto_path [linsert $auto_path 0 [file dirname $here]]

package require oo::meta
package require oo::dialect
oo::dialect::create tool

# Add a new keyword
proc ::tool::define::option {name def} {
  set class [current_class]
  oo::meta::info $class branchset option $name $def
}

# Override the "constructor" keyword
proc ::tool::define::constructor {arglist body} {
  set class [current_class]
  puts [list CONSTRUCTOR for $class]
  set prebody {
puts [list CREATED [self]]
my _optionInit
  }
  oo::define $class constructor $arglist "$prebody\n$body"
}

# Add functions to the core class
::tool::define ::tool::object {
  method _optionInit {} {
    my variable options meta
    if {![info exists meta]} {
      set meta {}
    }
    foreach {opt info} [my meta getnull option] {
      set options($opt) [dict getnull $info default:]
    }
  }
  method cget option {
    my variable options
    return $options($option)
  }
}

::tool::class create myclass {
  # Use our new option keyword
  option color {default: green}
  
  constructor {} {
    my variable meta
    set meta {}
  }
}

myclass create myobj
puts [myobj cget color]

source [file join $here .. tool dictobj.tcl]

::tool::define myclass {
  dictobj test test
}

myobj test set foo bar
puts [myobj test get foo]

Added modules/oodialect/oodialect.md.































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
The oo::dialect Package
=======================

*oo::dialect* is designed for building TclOO based domain specific languages. It does this
by providing:
* a meta class
* a core object
* A namespace in which to define additional keywords
* A "define" command to mirror the capabilties of *oo::define*

Example usage:
<pre>
<code>
package require oo::dialect
oo::dialect::create tool

# Add a new keyword
proc ::tool::define::option {name def} {
  set class [class_current]
  oo::meta::info $class branchset option $name $def
}

# Override the "constructor" keyword
proc ::tool::define::constructor {arglist body} {
  set class [class_current]
  set prebody {
my _optionInit
  }
  oo::define $class constructor $arglist "$prebody\n$body"
}

# Add functions to the core class
::tool::define ::tool::object {
  method _optionInit {} {
    my variable options
    foreach {opt info} [my meta getnull option] {
      set options($opt) [dict getnull $info default:]
    }
  }
  method cget option {
    my variable options
    return $options($option)
  }
}

</code>
</pre>

In practice, a new class of this dialect would look like:

<pre>
<code>
::tool::class create myclass {
  # Use our new option keyword
  option color {default: green}
}

myclass create myobj
puts [myobj cget color]
> green
</code>
</pre>

Added modules/oodialect/oodialect.tcl.

















































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
###
# oodialect.tcl
#
# Copyright (c) 2015-2018 Sean Woods
# Copyright (c) 2015 Donald K Fellows
#
# BSD License
###
# @@ Meta Begin
# Package oo::dialect 0.3.4
# Meta platform     tcl
# Meta summary      A utility for defining a domain specific language for TclOO systems
# Meta description  This package allows developers to generate
# Meta description  domain specific languages to describe TclOO
# Meta description  classes and objects.
# Meta category     TclOO
# Meta subject      oodialect
# Meta require      {Tcl 8.6}
# Meta author       Sean Woods
# Meta author       Donald K. Fellows
# Meta license      BSD
# @@ Meta End
namespace eval ::oo::dialect {
  namespace export create
}

# A stack of class names
proc ::oo::dialect::Push {class} {
  ::variable class_stack
  lappend class_stack $class
}
proc ::oo::dialect::Peek {} {
  ::variable class_stack
  return [lindex $class_stack end]
}
proc ::oo::dialect::Pop {} {
  ::variable class_stack
  set class_stack [lrange $class_stack 0 end-1]
}

###
# This proc will generate a namespace, a "mother of all classes", and a
# rudimentary set of policies for this dialect.
###
proc ::oo::dialect::create {name {parent ""}} {
  set NSPACE [NSNormalize [uplevel 1 {namespace current}] $name]
  ::namespace eval $NSPACE {::namespace eval define {}}
  ###
  # Build the "define" namespace
  ###
  if {$parent eq ""} {
  	###
  	# With no "parent" language, begin with all of the keywords in
  	# oo::define
  	###
  	foreach command [info commands ::oo::define::*] {
	    set procname [namespace tail $command]
	    interp alias {} ${NSPACE}::define::$procname {} \
    		::oo::dialect::DefineThunk $procname
  	}
  	# Create an empty dynamic_methods proc
    proc ${NSPACE}::dynamic_methods {class} {}
    namespace eval $NSPACE {
      ::namespace export dynamic_methods
      ::namespace eval define {::namespace export *}
    }
    set ANCESTORS {}
  } else {
    ###
  	# If we have a parent language, that language already has the
  	# [oo::define] keywords as well as additional keywords and behaviors.
  	# We should begin with that
  	###
  	set pnspace [NSNormalize [uplevel 1 {namespace current}] $parent]
    apply [list parent {
  	  ::namespace export dynamic_methods
  	  ::namespace import -force ${parent}::dynamic_methods
  	} $NSPACE] $pnspace

    apply [list parent {
  	  ::namespace import -force ${parent}::define::*
  	  ::namespace export *
  	} ${NSPACE}::define] $pnspace
      set ANCESTORS [list ${pnspace}::object]
  }
  ###
  # Build our dialect template functions
  ###
  proc ${NSPACE}::define {oclass args} [string map [list %NSPACE% $NSPACE] {
	###
	# To facilitate library reloading, allow
	# a dialect to create a class from DEFINE
	###
  set class [::oo::dialect::NSNormalize [uplevel 1 {namespace current}] $oclass]
    if {[info commands $class] eq {}} {
	    %NSPACE%::class create $class {*}${args}
    } else {
	    ::oo::dialect::Define %NSPACE% $class {*}${args}
    }
}]
  interp alias {} ${NSPACE}::define::current_class {} \
    ::oo::dialect::Peek
  interp alias {} ${NSPACE}::define::aliases {} \
    ::oo::dialect::Aliases $NSPACE
  interp alias {} ${NSPACE}::define::superclass {} \
    ::oo::dialect::SuperClass $NSPACE

  if {[info command ${NSPACE}::class] ne {}} {
    ::rename ${NSPACE}::class {}
  }
  ###
  # Build the metaclass for our language
  ###
  ::oo::class create ${NSPACE}::class {
    superclass ::oo::dialect::MotherOfAllMetaClasses
  }
  # Wire up the create method to add in the extra argument we need; the
  # MotherOfAllMetaClasses will know what to do with it.
  ::oo::objdefine ${NSPACE}::class \
    method create {name {definitionScript ""}} \
      "next \$name [list ${NSPACE}::define] \$definitionScript"

  ###
  # Build the mother of all classes. Note that $ANCESTORS is already
  # guaranteed to be a list in canonical form.
  ###
  uplevel #0 [string map [list %NSPACE% [list $NSPACE] %name% [list $name] %ANCESTORS% $ANCESTORS] {
    %NSPACE%::class create %NSPACE%::object {
     superclass %ANCESTORS%
      # Put MOACish stuff in here
    }
  }]
  if { "${NSPACE}::class" ni $::oo::dialect::core_classes } {
    lappend ::oo::dialect::core_classes "${NSPACE}::class"
  }
  if { "${NSPACE}::object" ni $::oo::dialect::core_classes } {
    lappend ::oo::dialect::core_classes "${NSPACE}::object"
  }
}

# Support commands; not intended to be called directly.
proc ::oo::dialect::NSNormalize {namespace qualname} {
  if {![string match ::* $qualname]} {
    set qualname ${namespace}::$qualname
  }
  regsub -all {::+} $qualname "::"
}

proc ::oo::dialect::DefineThunk {target args} {
  tailcall ::oo::define [Peek] $target {*}$args
}

proc ::oo::dialect::Canonical {namespace NSpace class} {
  namespace upvar $namespace cname cname
  #if {[string match ::* $class]} {
  #  return $class
  #}
  if {[info exists cname($class)]} {
    return $cname($class)
  }
  if {[info exists ::oo::dialect::cname($class)]} {
    return $::oo::dialect::cname($class)
  }
  if {[info exists ::oo::dialect::cname(${NSpace}::${class})]} {
    return $::oo::dialect::cname(${NSpace}::${class})
  }
  foreach item [list "${NSpace}::$class" "::$class"] {
    if {[info commands $item] ne {}} {
      return $item
    }
  }
  return ${NSpace}::$class
}

###
# Implementation of the languages' define command
###
proc ::oo::dialect::Define {namespace class args} {
  Push $class
  try {
  	if {[llength $args]==1} {
      namespace eval ${namespace}::define [lindex $args 0]
    } else {
      ${namespace}::define::[lindex $args 0] {*}[lrange $args 1 end]
    }
  	${namespace}::dynamic_methods $class
  } finally {
    Pop
  }
}

###
# Implementation of how we specify the other names that this class will answer
# to
###

proc ::oo::dialect::Aliases {namespace args} {
  set class [Peek]
  namespace upvar $namespace cname cname
  set NSpace [join [lrange [split $class ::] 1 end-2] ::]
  set cname($class) $class
  foreach name $args {
    set cname($name) $class
    #set alias $name
    set alias [NSNormalize $NSpace $name]
    # Add a local metaclass reference
    if {![info exists ::oo::dialect::cname($alias)]} {
      lappend ::oo::dialect::aliases($class) $alias
      ##
      # Add a global reference, first come, first served
      ##
      set ::oo::dialect::cname($alias) $class
    }
  }
}

###
# Implementation of a superclass keyword which will enforce the inheritance of
# our language's mother of all classes
###

proc ::oo::dialect::SuperClass {namespace args} {
  set class [Peek]
  namespace upvar $namespace class_info class_info
  dict set class_info($class) superclass 1
  set ::oo::dialect::cname($class) $class
  set NSpace [join [lrange [split $class ::] 1 end-2] ::]
  set unique {}
  foreach item $args {
    set Item [Canonical $namespace $NSpace $item]
    dict set unique $Item $item
  }
  set root ${namespace}::object
  if {$class ne $root} {
    dict set unique $root $root
  }
  tailcall ::oo::define $class superclass {*}[dict keys $unique]
}

###
# Implementation of the common portions of the the metaclass for our
# languages.
###

::oo::class create ::oo::dialect::MotherOfAllMetaClasses {
  superclass ::oo::class
  constructor {define definitionScript} {
    $define [self] {
      superclass
    }
    $define [self] $definitionScript
  }
  method aliases {} {
    if {[info exists ::oo::dialect::aliases([self])]} {
      return $::oo::dialect::aliases([self])
    }
  }
}

namespace eval ::oo::dialect {
  variable core_classes {::oo::class ::oo::object}
}

package provide oo::dialect 0.3.4

Added modules/oodialect/oodialect.test.



















































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
# tool.test - Copyright (c) 2015 Sean Woods
# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.6
testsNeedTcltest 2
testsNeed        TclOO 1

support {
    use dicttool/dicttool.tcl dicttool
    use oometa/oometa.tcl     oo::meta
}
testing {
    useLocal oodialect.tcl oo::dialect
}

# -------------------------------------------------------------------------

::oo::dialect::create ::alpha

proc ::alpha::define::is_alpha {} {
  dict set ::testinfo([current_class]) is_alpha 1
}

::alpha::define ::alpha::object {
  is_alpha
}

::oo::dialect::create ::bravo ::alpha

proc ::bravo::define::is_bravo {} {
  dict set ::testinfo([current_class]) is_bravo 1
}

::bravo::define ::bravo::object {
  is_bravo
}

::oo::dialect::create ::charlie ::bravo

proc ::charlie::define::is_charlie {} {
  dict set ::testinfo([current_class]) is_charlie 1
}

::charlie::define ::charlie::object {
  is_charlie
}

::oo::dialect::create ::delta ::charlie

proc ::delta::define::is_delta {} {
  dict set ::testinfo([current_class]) is_delta 1
}

::delta::define ::delta::object {
  is_delta
}

::delta::class create adam {
  is_alpha
  is_bravo
  is_charlie
  is_delta
}

test oodialect-keyword-001 {Testing keyword application} {
  set ::testinfo(::adam)
} {is_alpha 1 is_bravo 1 is_charlie 1 is_delta 1}

test oodialect-keyword-002 {Testing keyword application} {
  set ::testinfo(::alpha::object)
} {is_alpha 1}

test oodialect-keyword-003 {Testing keyword application} {
  set ::testinfo(::bravo::object)
} {is_bravo 1}

test oodialect-keyword-004 {Testing keyword application} {
  set ::testinfo(::charlie::object)
} {is_charlie 1}

test oodialect-keyword-005 {Testing keyword application} {
  set ::testinfo(::delta::object)
} {is_delta 1}

###
# Declare an object from a namespace
###
namespace eval ::test1 {
  ::alpha::class create a {
    aliases A
    is_alpha
  }
  ::alpha::define b {
    aliases B BEE
    is_alpha
  }
  ::alpha::class create ::c {
    aliases C
    is_alpha
  }
  ::alpha::define ::d {
    aliases D
    is_alpha
  }
}

test oodialect-naming-001 {Testing keyword application} {
  set ::testinfo(::test1::a)
} {is_alpha 1}

test oodialect-naming-002 {Testing keyword application} {
  set ::testinfo(::test1::b)
} {is_alpha 1}

test oodialect-naming-003 {Testing keyword application} {
  set ::testinfo(::c)
} {is_alpha 1}

test oodialect-naming-004 {Testing keyword application} {
  set ::testinfo(::d)
} {is_alpha 1}

test oodialect-aliasing-001 {Testing keyword application} {
namespace eval ::test1 {
    ::alpha::define e {
       superclass A
    }
}
} ::test1::e

test oodialect-aliasing-002 {Testing keyword application} {
namespace eval ::test1 {
    ::bravo::define f {
       superclass A
    }
}
} ::test1::f


test oodialect-aliasing-003 {Testing aliase method on class} {
  ::test1::a aliases
} {::test1::A}


test oodialect-ancestry-003 {Testing heritage} {
  ::oo::meta::ancestors ::test1::f
} {::oo::object ::alpha::object ::bravo::object ::test1::a ::test1::f}

test oodialect-ancestry-004 {Testing heritage} {
  ::oo::meta::ancestors ::alpha::object
} {::oo::object ::alpha::object}

test oodialect-ancestry-005 {Testing heritage} {
  ::oo::meta::ancestors ::delta::object
} {::oo::object ::alpha::object ::bravo::object ::charlie::object ::delta::object}

# -------------------------------------------------------------------------


testsuiteCleanup

# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:

Added modules/oodialect/pkgIndex.tcl.



>
1
package ifneeded oo::dialect 0.3.4 [list source [file join $dir oodialect.tcl]]

Added modules/oometa/oometa.demo.























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
source ../dicttool/dicttool.tcl
source oometa.tcl

oo::class create animal {
  meta set biodata animal: 1
}
oo::class create mammal {
  superclass animal
  meta set biodata mammal: 1
}
oo::class create cat {
  superclass mammal
  meta set biodata diet: carnivore
}

cat create felix
puts [felix meta get biodata]

felix meta set biodata likes: {birds mice}
puts [felix meta get biodata]

mammal meta set biodata metabolism: warm-blooded
puts [felix meta get biodata]

# Overwrite class info
felix meta set biodata mammal: yes
puts [felix meta get biodata]

Added modules/oometa/oometa.man.

















































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin oometa n 0.7.1]
[keywords TOOL]
[copyright {2015 Sean Woods <yoda@etoyoc.com>}]
[moddesc   {Data registry for TclOO frameworks}]
[titledesc {oo::meta A data registry for classess}]
[category TclOO]
[keywords TclOO]
[description]

The [cmd oo::meta] package provides a data registry service for TclOO classes.

[section Usage]

[example {
oo::class create animal {
  meta set biodata animal: 1
}
oo::class create mammal {
  superclass animal
  meta set biodata mammal: 1
}
oo::class create cat {
  superclass mammal
  meta set biodata diet: carnivore
}

cat create felix
puts [felix meta dump biodata]
> animal: 1 mammal: 1 diet: carnivore

felix meta set biodata likes: {birds mice}
puts [felix meta get biodata]
> animal: 1 mammal: 1 diet: carnivore likes: {bird mice}

# Modify a class
mammal meta set biodata metabolism: warm-blooded
puts [felix meta get biodata]
> animal: 1 mammal: 1 metabolism: warm-blooded diet: carnivore likes: {birds mice}

# Overwrite class info
felix meta set biodata mammal: yes
puts [felix meta get biodata]
> animal: 1 mammal: yes metabolism: warm-blooded diet: carnivore likes: {birds mice}
}]
[section Concept]
The concept behind [cmd oo::meta] is that each class contributes a snippet of [emph local] data.
When [cmd oo::meta::metadata] is called, the system walks through the linear ancestry produced by
[cmd oo::meta::ancestors], and recursively combines all of that local data for all of a class'
ancestors into a single dict.

Instances of oo::object can also combine class data with a local dict stored in the [emph meta] variable.

[section COMMANDS]

[list_begin definitions]

[call [cmd oo::meta::info]]

[cmd oo::meta::info] is intended to work on the metadata of a class in a manner similar to if the aggregate
pieces where assembled into a single dict. The system mimics all of the standard dict commands, and addes
the following:

[call [cmd {oo::meta::info branchget}] [opt [arg key]] [opt ...]]

Returns a dict representation of the element at [emph args], but with any trailing : removed from field names.

[example {
::oo::meta::info $myclass set option color {default: green widget: colorselect}
puts [::oo::meta::info $myclass get option color]
> {default: green widget: color}
puts [::oo::meta::info $myclass branchget option color]
> {default green widget color}
}]

[call [cmd {oo::meta::info branchset}] [opt [arg key...]] [arg key] [arg value]]

Merges [emph dict] with any other information contaned at node [opt [arg key...]], and adding a trailing :
to all field names.

[example {
::oo::meta::info $myclass branchset option color {default green widget colorselect}
puts [::oo::meta::info $myclass get option color]
> {default: green widget: color}
}]

[call [cmd {oo::meta::info dump}] [arg class]]

Returns the complete snapshot of a class metadata, as producted by [cmd oo::meta::metadata]

[call [cmd oo::meta::info] [arg class] [cmd is] [arg type] [opt [arg args]]]

Returns a boolean true or false if the element [opt [arg args]] would match [cmd {string is}] [arg type] [arg value]

[example {
::oo::meta::info $myclass set constant mammal 1
puts [::oo::meta::info $myclass is true constant mammal]
> 1
}]

[call [cmd oo::meta::info] [arg class] [cmd merge] [opt [arg dict]] [opt [arg dict]] [opt [arg ...]]]

Combines all of the arguments into a single dict, which is then stored as the new
local representation for this class.

[call [cmd oo::meta::info] [arg class] [cmd rebuild]]

Forces the meta system to destroy any cached representation of a class' metadata before
the next access to [cmd oo::meta::metadata]

[call [cmd oo::meta::metadata] [arg class]]

Returns an aggregate picture of the metadata for [arg class], combining its [emph local] data
with the [emph local] data from its ancestors.

[call [cmd {oo::define meta}]]

The package injects a command [cmd oo::define::meta] which works to provide a class in the
process of definition access to [cmd oo::meta::info], but without having to look the name up.

[example {
oo::define myclass {
  meta set foo bar: baz
}
}]

[call [cmd {oo::class method meta}]]

The package injects a new method [cmd meta] into [cmd oo::class] which works to provide a class
instance access to [cmd oo::meta::info].

[call [cmd {oo::object method meta}]]

The package injects a new method [cmd meta] into [cmd oo::object]. [cmd oo::object] combines the data
for its class (as provided by [cmd oo::meta::metadata]), with a local variable [emph meta] to
produce a local picture of metadata.

This method provides the following additional commands:

[call [cmd {oo::object method meta cget}] [opt [arg field]] [opt [arg ...]] [arg field]]

Attempts to locate a singlar leaf, and return its value. For single option lookups, this
is faster than [cmd {my meta getnull}] [opt [arg field]] [opt [arg ...]] [arg field]], because
it performs a search instead directly instead of producing the recursive merge product
between the class metadata, the local [emph meta] variable, and THEN performing the search.

[list_end]

[vset CATEGORY tcloo]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

Added modules/oometa/oometa.md.









































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
The oo::meta package
============

The *oo::meta* package provides a data registry service for TclOO classes. It works by
providing the following:

* The **oo::meta::info** command, providing data introspection and manipulation
* The **oo::meta::metadata** command, providing a snapshot of the data per class instance
* The **oo::meta::ancestors** command, providing a linear representation of a class's inheritance tree
* A **meta** keyword in *oo::define*, to provide easy access to the data from within class definition bodies.
* A **meta** method for *oo::class*, to provide easy access to the data from a class instance
* A **meta** method for *oo::object*, which combines data from the class with a local *meta* variable

## Usage
<pre><code>
oo::class create animal {
  meta set biodata animal: 1
}
oo::class create mammal {
  superclass animal
  meta set biodata mammal: 1
}
oo::class create cat {
  superclass mammal
  meta set biodata diet: carnivore
}

cat create felix
puts [felix meta dump biodata]
> animal: 1 mammal: 1 diet: carnivore

felix meta set biodata likes: {birds mice}
puts [felix meta get biodata]
> animal: 1 mammal: 1 diet: carnivore likes: {bird mice}

# Modify a class
mammal meta set biodata metabolism: warm-blooded
puts [felix meta get biodata]
> animal: 1 mammal: 1 metabolism: warm-blooded diet: carnivore likes: {birds mice}

# Overwrite class info
felix meta set biodata mammal: yes
puts [felix meta get biodata]
> animal: 1 mammal: yes metabolism: warm-blooded diet: carnivore likes: {birds mice}
</code></pre>

## Concept
The concept behind *oo::meta* is that each class contributes a snippet of *local* data. When
**oo::meta::metadata** is called, the system walks through the linear ancestry produced by
**oo::meta::ancestors**, and recursively combines all of that local data for all of a class'
ancestors into a single dict.

Instances of oo::object can also combine class data with a local dict stored in the *meta* variable.

### oo::meta::info
*oo::meta::info* is intended to work on the metadata of a class in a manner similar to if the aggregate
pieces where assembled into a single dict. The system mimics all of the standard dict commands, and addes
the following:

#### oo::meta::info *class* branchget *?key...?* key
Returns a dict representation of the element at *args*, but with any trailing : removed from field names.

<pre><code>
::oo::meta::info $myclass set option color {default: green widget: colorselect}
puts [::oo::meta::info $myclass get option color]
> {default: green widget: color}
puts [::oo::meta::info $myclass branchget option color]
> {default green widget color}
</code></pre>

#### oo::meta::info *class* branchset *?key...? key dict*
Merges *dict* with any other information contaned at node *?key...?*, and adding a trailing :
to all field names.

<pre><code>
::oo::meta::info $myclass branchset option color {default green widget colorselect}
puts [::oo::meta::info $myclass get option color]
> {default: green widget: color}
</code></pre>

#### oo::meta::dump *class*
Returns the complete snapshot of a class metadata, as producted by **oo::meta::metadata**

#### oo::meta::info *class* is *type* *args*
Returns a boolean true or false if the element *args* would match **string is *type* *value***
<pre><code>
::oo::meta::info $myclass set constant mammal 1
puts [::oo::meta::info $myclass is true constant mammal]
> 1
</code></pre>

#### oo::meta::info *class* merge *dict* *dict* ?*dict...*?
Combines all of the arguments into a single dict, which is then stored as the new
local representation for this class.

#### oo::meta::info *class* rebuild
Forces the meta system to destroy any cached representation of a class' metadata before
the next access to **oo::meta::metadata**

### oo::meta::metadata *class*
Returns an aggregate picture of the metadata for *class*, combining its *local* data
with the *local* data from every class it is descended from.

## **meta** keyword
The package injects a command **oo::define::meta** which works to provide a class in the
process of definition access to **oo::meta::info**, but without having to look the name up.

## **meta** keyword
The package injects a command **oo::define::meta** which works to provide a class in the
process of definition access to **oo::meta::info** *class*, but without having
to look the name up.

## oo::class method **meta**
The package injects a new method **meta** into *oo::class* which works to provide a class
instance access to **oo::meta::info**.

## oo::object method **meta**
The package injects a new method **meta** into *oo::object*. oo::object combines the data
for its class (as provided by **oo::meta::metadata**), with a local variable *meta* to
produce a local picture of metadata.

This method provides the following additional commands:

#### method meta cget *?field...? field*
Attempts to locate a singlar leaf, and return its value. For single option lookups, this
is faster than [my meta getnull *?field...? field*], because it performs a search instead
directly instead of producing the recursive merge product between the class metadata, the
local *meta* variable, and THEN performing the search.




Added modules/oometa/oometa.tcl.













































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
###
# Author: Sean Woods, yoda@etoyoc.com
##
# TclOO routines to implement property tracking by class and object
###
package require Tcl 8.6 ;# tailcall
package require dicttool
package require oo::dialect
package provide oo::meta 0.7.2

namespace eval ::oo::meta {
  set dirty_classes {}
}

proc ::oo::meta::args_to_dict args {
  if {[llength $args]==1} {
    return [lindex $args 0]
  }
  return $args
}

proc ::oo::meta::args_to_options args {
  set result {}
  foreach {var val} [args_to_dict {*}$args] {
    lappend result [string trimleft $var -] $val
  }
  return $result
}

proc ::oo::meta::ancestors class {
  set class [::oo::meta::normalize $class]
  set core_result {}
  set queue $class
  set result {}
  # Rig things such that that the top superclasses
  # are evaluated first
  while {[llength $queue]} {
    set tqueue $queue
    set queue {}
    foreach qclass $tqueue {
      if {$qclass in $::oo::dialect::core_classes} {
        if {$qclass ni $core_result} {
          lappend core_result $qclass
        }
        continue
      }
      foreach aclass [::info class superclasses $qclass] {
        if { $aclass in $result } continue
        if { $aclass in $core_result } continue
        if { $aclass in $queue } continue
        lappend queue $aclass
      }
    }
    foreach item $tqueue {
      if {$item in $core_result} continue
      if { $item ni $result } {
        set result [linsert $result 0 $item]
      }
    }
  }
  # Handle core classes last
  set queue $core_result
  while {[llength $queue]} {
    set tqueue $queue
    set queue {}
    foreach qclass $tqueue {
      foreach aclass [::info class superclasses $qclass] {
        if { $aclass in $result } continue
        if { $aclass in $queue } continue
        lappend queue $aclass
      }
    }
    foreach item $tqueue {
      if { $item ni $result } {
        set result [linsert $result 0 $item]
      }
    }
  }
  return $result
}

proc oo::meta::info {class submethod args} {
  set class [::oo::meta::normalize $class]
  switch $submethod {
    cget {
      ###
      # submethod: cget
      # arguments: ?*path* ...? *field*
      # format: markdown
      # description:
      # Retrieve a value from the class' meta data. Values are searched in the
      # following order:
      # 1. From class meta data as const **path** **field:**
      # 2. From class meta data as const **path** **field**
      # 3. From class meta data as **path** **field:**
      # 4. From class meta data as **path** **field**
      ###
      set path [lrange $args 0 end-1]
      set field [string trimright [lindex $args end] :]
      foreach mclass [lreverse [::oo::meta::ancestors $class]] {
        if {![::info exists ::oo::meta::local_property($mclass)]} continue
        set class_metadata $::oo::meta::local_property($mclass)
        if {[dict exists $class_metadata const {*}$path $field:]} {
          return [dict get $class_metadata const {*}$path $field:]
        }
        if {[dict exists $class_metadata const {*}$path $field]} {
          return [dict get $class_metadata const {*}$path $field]
        }
        if {[dict exists $class_metadata {*}$path $field:]} {
          return [dict get $class_metadata {*}$path $field:]
        }
        if {[dict exists $class_metadata {*}$path $field]} {
          return [dict get $class_metadata {*}$path $field]
        }
      }
      return {}
    }
    rebuild {
      ::oo::meta::rebuild $class
    }
    is {
      set info [metadata $class]
      return [string is [lindex $args 0] -strict [dict getnull $info {*}[lrange $args 1 end]]]
    }
    for -
    map {
      set info [metadata $class]
      uplevel 1 [list ::dict $submethod [lindex $args 0] [dict get $info {*}[lrange $args 1 end-1]] [lindex $args end]]
    }
    with {
      upvar 1 TEMPVAR info
      set info [metadata $class]
      return [uplevel 1 [list ::dict with TEMPVAR {*}$args]]
    }
    branchget {
      set info [metadata $class]
      set result {}
      foreach {field value} [dict getnull $info {*}$args] {
        dict set result [string trimright $field :] $value
      }
      return $result
    }
    branchset {
      ::oo::meta::rebuild $class
      foreach {field value} [lindex $args end] {
        ::dict set ::oo::meta::local_property($class) {*}[lrange $args 0 end-1] [string trimright $field :]: $value
      }
    }
    leaf_add {
      if {[::info exists ::oo::meta::local_property($class)]} {
        set result [dict getnull $::oo::meta::local_property($class) {*}[lindex $args 0]]
      }
      ladd result {*}[lrange $args 1 end]
      dict set ::oo::meta::local_property($class) {*}[lindex $args 0] $result
    }
    leaf_remove {
      if {![::info exists ::oo::meta::local_property($class)]} return
      set result {}
      forearch element [dict getnull $::oo::meta::local_property($class) {*}[lindex $args 0]] {
        if { $element in [lrange $args 1 end]} continue
        lappend result $element
      }
      dict set ::oo::meta::local_property($class) {*}[lindex $args 0] $result
    }
    append -
    incr -
    lappend -
    set -
    unset -
    update {
      ::oo::meta::rebuild $class
      ::dict $submethod ::oo::meta::local_property($class) {*}$args
    }
    merge {
      ::oo::meta::rebuild $class
      set ::oo::meta::local_property($class) [dict rmerge $::oo::meta::local_property($class) {*}$args]
    }
    dump {
      set info [metadata $class]
      return $info
    }
    default {
      set info [metadata $class]
      return [::dict $submethod $info {*}$args]
    }
  }
}

proc ::oo::meta::localdata {class args} {
  if {![::info exists ::oo::meta::local_property($class)]} {
    return {}
  }
  if {[::llength $args]==0} {
    return $::oo::meta::local_property($class)
  }
  return [::dict getnull $::oo::meta::local_property($class) {*}$args]
}

proc ::oo::meta::normalize class {
  set class ::[string trimleft $class :]
}

proc ::oo::meta::metadata {class {force 0}} {
  set class [::oo::meta::normalize $class]
  ###
  # Destroy the cache of all derivitive classes
  ###
  if {$force} {
    unset -nocomplain ::oo::meta::cached_property
    unset -nocomplain ::oo::meta::cached_hierarchy
  } else {
    variable dirty_classes
    foreach dclass $dirty_classes {
      foreach {cclass cancestors} [array get ::oo::meta::cached_hierarchy] {
        if {$dclass in $cancestors} {
          unset -nocomplain ::oo::meta::cached_property($cclass)
          unset -nocomplain ::oo::meta::cached_hierarchy($cclass)
        }
      }
      if {![::info exists ::oo::meta::local_property($dclass)]} continue
      if {[dict getnull $::oo::meta::local_property($dclass) classinfo type:] eq "core"} {
        if {$dclass ni $::oo::dialect::core_classes} {
          lappend ::oo::dialect::core_classes $dclass
        }
      }
    }
    set dirty_classes {}
  }

  ###
  # If the cache is available, use it
  ###
  variable cached_property
  if {[::info exists cached_property($class)]} {
    return $cached_property($class)
  }
  ###
  # Build a cache of the hierarchy and the
  # aggregate metadata for this class and store
  # them for future use
  ###
  variable cached_hierarchy
  set metadata {}
  set stack {}
  variable local_property
  set cached_hierarchy($class) [::oo::meta::ancestors $class]
  foreach class $cached_hierarchy($class) {
    if {[::info exists local_property($class)]} {
      lappend metadata $local_property($class)
    }
  }
  #foreach aclass [lreverse [::info class superclasses $class]] {
  #  lappend metadata [::oo::meta::metadata $aclass]
  #}

  lappend metadata {classinfo {type: {}}}
  if {[::info exists local_property($class)]} {
    lappend metadata $local_property($class)
  }
  set metadata [dict rmerge {*}$metadata]
  set cached_property($class) $metadata
  return $metadata
}

proc ::oo::meta::rebuild args {
  foreach class $args {
    if {$class ni $::oo::meta::dirty_classes} {
      lappend ::oo::meta::dirty_classes $class
    }
  }
}

proc ::oo::meta::search args {
  variable local_property

  set path [lrange $args 0 end-1]
  set value [lindex $args end]

  set result {}
  foreach {class info} [array get local_property] {
    if {[dict exists $info {*}$path:]} {
      if {[string match [dict get $info {*}$path:] $value]} {
        lappend result $class
      }
      continue
    }
    if {[dict exists $info {*}$path]} {
      if {[string match [dict get $info {*}$path] $value]} {
        lappend result $class
      }
    }
  }
  return $result
}

proc ::oo::define::meta {args} {
  set class [lindex [::info level -1] 1]
  if {[lindex $args 0] in "cget set branchset"} {
    ::oo::meta::info $class {*}$args
  } else {
    ::oo::meta::info $class set {*}$args
  }
}

oo::define oo::class {
  method meta {submethod args} {
    tailcall ::oo::meta::info [self] $submethod {*}$args
  }
}

oo::define oo::object {
  ###
  # title: Provide access to meta data
  # format: markdown
  # description:
  # The *meta* method allows an object access
  # to a combination of its own meta data as
  # well as to that of its class
  ###
  method meta {submethod args} {
    my variable meta MetaMixin
    if {![info exists MetaMixin]} {
      set MetaMixin {}
    }
    set class [::info object class [self object]]
    set classlist [list $class {*}$MetaMixin]
    switch $submethod {
      cget {
        ###
        # submethod: cget
        # arguments: ?*path* ...? *field*
        # format: markdown
        # description:
        # Retrieve a value from the local objects **meta** dict
        # or from the class' meta data. Values are searched in the
        # following order:
        # 0. (If path length==1) From the _config array
        # 1. From the local dict as **path** **field:**
        # 2. From the local dict as **path** **field**
        # 3. From class meta data as const **path** **field:**
        # 4. From class meta data as const **path** **field**
        # 5. From class meta data as **path** **field:**
        # 6. From class meta data as **path** **field**
        ###
        set path [lrange $args 0 end-1]
        set field [string trim [lindex $args end] :]
        if {[dict exists $meta {*}$path $field:]} {
          return [dict get $meta {*}$path $field:]
        }
        if {[dict exists $meta {*}$path $field]} {
          return [dict get $meta {*}$path $field]
        }
        foreach mclass [lreverse $classlist] {
          set class_metadata [::oo::meta::metadata $mclass]
          if {[dict exists $class_metadata const {*}$path $field:]} {
            return [dict get $class_metadata const {*}$path $field:]
          }
          if {[dict exists $class_metadata const {*}$path $field]} {
            return [dict get $class_metadata const {*}$path $field]
          }
          if {[dict exists $class_metadata {*}$path $field:]} {
            return [dict get $class_metadata {*}$path $field:]
          }
          if {[dict exists $class_metadata {*}$path $field]} {
            return [dict get $class_metadata {*}$path $field]
          }
        }
        return {}
      }
      is {
        set value [my meta cget {*}[lrange $args 1 end]]
        return [string is [lindex $args 0] -strict $value]
      }
      for -
      map {
        foreach mclass $classlist {
          lappend mdata [::oo::meta::metadata $mclass]
        }
        set info [dict rmerge {*}$mdata $meta]
        uplevel 1 [list ::dict $submethod [lindex $args 0] [dict get $info {*}[lrange $args 1 end-1]] [lindex $args end]]
      }
      with {
        upvar 1 TEMPVAR info
        foreach mclass $classlist {
          lappend mdata [::oo::meta::metadata $mclass]
        }
        set info [dict rmerge {*}$mdata $meta]
        return [uplevel 1 [list dict with TEMPVAR {*}$args]]
      }
      dump {
        foreach mclass $classlist {
          lappend mdata [::oo::meta::metadata $mclass]
        }
        return [dict rmerge {*}$mdata $meta]
      }
      append -
      incr -
      lappend -
      set -
      unset -
      update {
        return [dict $submethod meta {*}$args]
      }
      branchset {
        foreach {field value} [lindex $args end] {
          dict set meta {*}[lrange $args 0 end-1] [string trimright $field :]: $value
        }
      }
      rmerge -
      merge {
        set meta [dict rmerge $meta {*}$args]
        return $meta
      }
      exists {
        foreach mclass $classlist {
          if {[dict exists [::oo::meta::metadata $mclass] {*}$args]} {
            return 1
          }
        }
        if {[dict exists $meta {*}$args]} {
          return 1
        }
        return 0
      }
      get -
      getnull {
        if {[string index [lindex $args end] end]==":"} {
          # Looking for a leaf node
          if {[dict exists $meta {*}$args]} {
            return [dict get $meta {*}$args]
          }
          foreach mclass [lreverse $classlist] {
            set mdata [::oo::meta::metadata $mclass]
            if {[dict exists $mdata {*}$args]} {
              return [dict get $mdata {*}$args]
            }
          }
          if {$submethod == "get"} {
            error "key \"$args\" not known in metadata"
          }
          return {}
        }
        # Looking for a branch node
        # So we need to composite the result
        set found 0
        foreach mclass $classlist {
          set mdata [::oo::meta::metadata $mclass]
          if {[dict exists $mdata {*}$args]} {
            set found 1
            lappend result [dict get $mdata {*}$args]
          }
        }
        if {[dict exists $meta {*}$args]} {
          set found 1
          lappend result [dict get $meta {*}$args]
        }
        if {!$found} {
          if {$submethod == "get"} {
            error "key \"$args\" not known in metadata"
          }
          return {}
        }
        return [dict rmerge {*}$result]
      }
      branchget {
        set result {}
        foreach mclass [lreverse $classlist] {
          foreach {field value} [dict getnull [::oo::meta::metadata $mclass] {*}$args] {
            dict set result [string trimright $field :] $value
          }
        }
        foreach {field value} [dict getnull $meta {*}$args] {
          dict set result [string trimright $field :] $value
        }
        return $result
      }
      mixin {
        foreach mclass $args {
          set mclass [::oo::meta::normalize $mclass]
          if {$mclass ni $MetaMixin} {
            lappend MetaMixin $mclass
          }
        }
      }
      mixout {
        foreach mclass $args {
          set mclass [::oo::meta::normalize $mclass]
          while {[set i [lsearch $MetaMixin $mclass]]>=0} {
            set MetaMixin [lreplace $MetaMixin $i $i]
          }
        }
      }
      default {
        foreach mclass $classlist {
          lappend mdata [::oo::meta::metadata $mclass]
        }
        set info [dict rmerge {*}$mdata $meta]
        return [dict $submethod $info {*}$args]
      }
    }
  }
}

Added modules/oometa/oometa.test.























































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
# oometa.test - Copyright (c) 2016 Sean Woods

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.6 ;# tailcall in oo::meta
testsNeedTcltest 2
testsNeed        TclOO

testing {
  useLocal oometa.tcl   oo::meta
  useLocal oooption.tcl oo::option
}

# -------------------------------------------------------------------------
# Test properties

oo::class create foo {
  meta set const color: blue
  
  constructor args {
    my _staticInit
    my configure {*}$args
  }
}

oo::class create bar {
  superclass ::foo
  meta set const shape: oval
  option color {
    label Color
    default green
  }
}

test oo-class-meta-001 {Test accessing properties} {
  foo meta get const color:
} blue

test oo-class-meta-002 {Test accessing properties} {
  bar meta get const color:
} blue

test oo-class-meta-003 {Test accessing properties} {
  bar meta get const shape:
} oval

bar create cheers color pink
# Pulling the meta data from const will return
# the value specified in the class
test oo-object-meta-001 {Test accessing properties} {
  cheers meta get const color:
} blue

# Accessing the data via cget pulls from the local
# definition
test oo-object-meta-001a {Test accessing properties} {
  cheers meta cget color
} green
# pink - Meta CGET is no longer connected to the local object's config

# With or without the trailing :
test oo-object-meta-001b {Test accessing properties} {
  cheers meta cget color:
} green
# pink - Meta CGET is no longer connected to the local object's config

# And using the local cget
test oo-object-meta-001c {Test accessing properties} {
  cheers cget color
} pink

test  oo-object-meta-002 {Test accessing properties} {
  cheers meta get const shape:
} oval

test  oo-object-meta-003 {Test accessing properties} {
  cheers cget color
} pink

bar create moes
test  oo-object-meta-004 {Test accessing properties} {
  moes meta get const color:
} blue

test  oo-object-meta-004a {Test accessing properties} {
  moes cget color
} green

test  oo-object-meta-004a {Test accessing properties} {
  moes cget color:
} green

test  oo-object-meta-005 {Test accessing properties} {
  moes meta get const shape:
} oval

test  oo-object-meta-006 {Test accessing properties} {
  moes cget color
} green

test  oo-object-meta-007 {Test the CGET retrieves a property if an option doesn't exist} {
  moes cget shape
} oval

###
# Test altering a property
###

#oo::define ::foo property woozle whoop
::foo meta set const woozle: whoop

test oo-modclass-meta-001 {Test accessing properties of an altered class} {
  foo meta get const woozle:
} whoop

test oo-modclass-meta-002 {Test accessing properties of the descendent of an altered class} {
  bar meta get const woozle:
} whoop

test oo-modobject-meta-001 {Test the accessing of properties of an instance of an altered class} {
  moes meta get const woozle:
} whoop

test obj-meta-for-001 {Test object meta for} {
  set output {}
  moes meta for {key value} option {
    lappend output $key $value
  }
  set output
} {color {label: Color default: green}}

test obj-meta-with-001 {Test object meta with} {
  set result {}
  moes meta with option {}
  set color
} {label: Color default: green}

test class-meta-for-001 {Test class meta for} {
  set output {}
  bar meta for {key value} option {
    lappend output $key $value
  }
  set output
} {color {label: Color default: green}}

test class-meta-with-001 {Test class meta with} {
  set result {}
  bar meta with option {}
  set color
} {label: Color default: green}

# -------------------------------------------------------------------------

# Test of recursive dicts

oo::class create baz {
  superclass ::bar
  meta set option color default: purple  
}

test obj-meta-recursive-1 {Test that meta set works with recursive dicts} {
  set result {}
  baz meta get option color default:
} {purple}

test obj-meta-recursive-2 {Test that meta set works with recursive dicts} {
  set result {}
  baz meta get option color label:
} {Color}


###
# New test, of mixins
###
oo::class create mixin-test-A {
  meta set const color: blue
  meta set field {
    pkey {name: {Primary Key} type: integer}
    name {name: {Unit Name} type: string}
    typefield {name: {Type Field} type: integer}
  }
  constructor args {
    my _staticInit
    my configure {*}$args
  }
}

oo::class create mixin-test-B {
  meta set const shape: oval
  meta set field {
    location {name: {Location} type: vector}
    typefield {name: {Type Field} type: custom}
  }
  option color {
    label Color
    default green
  }
  constructor args {
    my _staticInit
    my configure {*}$args
  }
}

mixin-test-B create MTB

test obj-mixin-001 {Test that meta prior to meta mixin we don't have a color} {
  MTB meta exists const color:
} 0

MTB meta mixin mixin-test-A
test obj-mixin-002 {Test that prior to meta mixin we don't have a color} {
  MTB meta exists const color:
} 1
test obj-mixin-002 {Test that after meta mixin we do have a color} {
  MTB meta get const color:
} blue
test obj-mixin-003 {Test that after meta mixin we can access the field dict} {
  MTB meta get field pkey name:
} {Primary Key}
test obj-mixin-004 {Test that after meta mixin we can access the field dict's local only value} {
  MTB meta get field location type:
} vector
test obj-mixin-005 {Test that mixed in data overrides conflicting local data} {
  MTB meta get field typefield type:
} integer
testsuiteCleanup

# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:

Added modules/oometa/oooption.tcl.



















































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
###
# Option handling for TclOO
###
package require Tcl 8.6 ;# due oo::meta
package require oo::meta 0.4

proc ::oo::define::option {field argdict} {
  set class [lindex [::info level -1] 1]
  foreach {prop value} $argdict {
    ::oo::meta::info $class set option $field [string trim $prop :]: $value
  }
}

oo::define oo::object {
  
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  method _staticInit {} {
    my variable meta
    if {![info exists meta]} {
      set meta {}
    }
    set dat [my meta getnull option]
    foreach {var info} $dat {
      if {[dict exists $info set-command:]} {
        if {[catch {my cget $var} value]} {
          dict set meta $var [my cget $var default:]
        } else {
          if { $value eq {} } {
            dict set meta $var [my cget $var default:]
          }
        }
      }
      if {![dict exists $meta $var]} {
        dict set meta $var [my cget $var default:]
      }
    }
    foreach {var info} [my meta getnull variable] {
      if { $var eq "meta" } continue
      my variable $var
      if {![info exists $var]} {
        if {[dict exists $info default:]} {
          set $var [dict get $info default:]
        } else {
          set $var {}
        }
      }
    }
    foreach {var info} [my meta getnull array] {
      if { $var eq "meta" } continue
      my variable $var
      if {![info exists $var]} {
        if {[dict exists $info default:]} {
          array set $var [dict get $info default:]
        } else {
          array set $var {}
        }
      }
    }
  }

  ###
  # topic: 86a1b968cea8d439df87585afdbdaadb
  ###
  method cget {field {default {}}} {
    my variable _config
    set field [string trimleft $field -]
    set dat [my meta getnull option]
  
    if {[my meta is true const options_strict:] && ![dict exists $dat $field]} {
      error "Invalid option -$field. Valid: [dict keys $dat]"
    }
    set info [dict getnull $dat $field]    
    if {$default eq "default"} {
      set getcmd [dict getnull $info default-command:]
      if {$getcmd ne {}} {
        return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
      } else {
        return [dict getnull $info default:]
      }
    }
    if {[dict exists $dat $field]} {
      set getcmd [dict getnull $info get-command:]
      if {$getcmd ne {}} {
        return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
      }
      if {![info exists _config($field)]} {
        set getcmd [dict getnull $info default-command:]
        if {$getcmd ne {}} {
          set _config($field) [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
        } else {
          set _config($field) [dict getnull $info default:]
        }
      }
      if {$default eq "varname"} {
        set varname [my varname _config]
        return "${varname}($field)"
      }
      return $_config($field)
    }
    return [my meta cget $field]
  }
  
  ###
  # topic: 73e2566466b836cc4535f1a437c391b0
  ###
  method configure args {
    # Will be removed at the end of "configurelist_triggers"
    set dictargs [::oo::meta::args_to_options {*}$args]
    if {[llength $dictargs] == 1} {
      return [my cget [lindex $dictargs 0]]
    }
    my configurelist $dictargs
    my configurelist_triggers $dictargs
  }

  ###
  # topic: dc9fba12ec23a3ad000c66aea17135a5
  ###
  method configurelist dictargs {
    my variable _config
    set dat [my meta getnull option]
    if {[my meta is true const options_strict:]} {
      foreach {field val} $dictargs {
        if {![dict exists $dat $field]} {
          error "Invalid option $field. Valid: [dict keys $dat]"
        }
      }
    }
    ###
    # Validate all inputs
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field validate-command:]
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
    ###
    # Apply all inputs with special rules
    ###
    array set _config $dictargs
  }

  ###
  # topic: 543c936485189593f0b9ed79b5d5f2c0
  ###
  method configurelist_triggers dictargs {
    set dat [my meta getnull option]
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field set-command:]
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
  }
}
package provide oo::option 0.3.1

Added modules/oometa/pkgIndex.tcl.

















>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
#checker -scope global exclude warnUndefinedVar
# var in question is 'dir'.
if {![package vsatisfies [package provide Tcl] 8.6]} {
    # PRAGMA: returnok
    return
}
package ifneeded oo::meta   0.7.2 [list source [file join $dir oometa.tcl]]
package ifneeded oo::option 0.3.1 [list source [file join $dir oooption.tcl]]

Changes to modules/taotk/widget/combobox.tcl.

2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
    }
}

# For now ... just wrap it
proc ::tao::combobox args {
  tailcall ::combobox::combobox {*}$args
}
if {$::taotk::winsys == "aqua"} {
  rename ::ttk::combobox ::ttk::_combobox
  proc ::ttk::combobox {w args} {
    tailcall ::combobox::combobox $w {*}$args
  }
}







<
<
<
<
|
<
2087
2088
2089
2090
2091
2092
2093




2094

    }
}

# For now ... just wrap it
proc ::tao::combobox args {
  tailcall ::combobox::combobox {*}$args
}






Added modules/tool/build/build.tcl.

































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
set srcdir [file dirname [file normalize [file join [pwd] [info script]]]]
set moddir [file dirname $srcdir]

set version 0.7
set module [file tail $moddir]

set fout [open [file join $moddir ${module}.tcl] w]
dict set map %module% $module
dict set map %version% $version

puts $fout [string map $map {###
# Amalgamated package for %module%
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package provide %module% %version%
namespace eval ::%module% {}
}]
if {$module ne "tool"} {
  puts $fout [string map $map {::tool::module push %module%}]
}

# Track what files we have included so far
set loaded {}
lappend loaded build.tcl

# These files must be loaded in a particular order
foreach file {
  core.tcl
  uuid.tcl
  ensemble.tcl
  metaclass.tcl
  option.tcl
  event.tcl
  pipeline.tcl
} {
  lappend loaded $file
  set fin [open [file join $srcdir $file] r]
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [read $fin]
  close $fin
  puts $fout "###\n# END: [file tail $file]\n###"
}
# These files can be loaded in any order
foreach file [lsort -dictionary [glob [file join $srcdir *.tcl]]] {
  if {[file tail $file] in $loaded} continue
  lappend loaded $file
  set fin [open [file join $srcdir $file] r]
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [read $fin]
  close $fin
  puts $fout "###\n# END: [file tail $file]\n###"
}

# Provide some cleanup and our final package provide
puts $fout [string map $map {
namespace eval ::%module% {
  namespace export *
}
}]
close $fout

###
# Build our pkgIndex.tcl file
###
set fout [open [file join $moddir pkgIndex.tcl] w]
puts $fout [string map $map {# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded %module% %version% [list source [file join $dir %module%.tcl]]
}]
close $fout

Added modules/tool/build/core.tcl.





































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
package require dicttool
package require TclOO
package require sha1
#package require cron 2.0
package require oo::meta 0.5.1
package require oo::dialect

::oo::dialect::create ::tool
::namespace eval ::tool {}
set ::tool::trace 0

proc ::tool::script_path {} {
  set path [file dirname [file join [pwd] [info script]]]
  return $path
}

proc ::tool::module {cmd args} {
  ::variable moduleStack
  ::variable module

  switch $cmd {
    push {
      set module [lindex $args 0]
      lappend moduleStack $module
      return $module
    }
    pop {
      set priormodule      [lindex $moduleStack end]
      set moduleStack [lrange $moduleStack 0 end-1]
      set module [lindex $moduleStack end]
      return $priormodule
    }
    peek {
      set module      [lindex $moduleStack end]
      return $module
    }
    default {
      error "Invalid command \"$cmd\". Valid: peek, pop, push"
    }
  }
}
::tool::module push core

proc ::tool::pathload {path {order {}} {skip {}}} {
  ###
  # On windows while running under a VFS, the system sometimes
  # gets confused about the volume we are running under
  ###
  if {$::tcl_platform(platform) eq "windows"} {
    if {[string range $path 1 6] eq ":/zvfs"} {
      set path [string range $path 2 end]
    }
  }
  set loaded {pkgIndex.tcl index.tcl}
  foreach item $skip {
    lappend loaded [file tail $skip]
  }
  if {[file exists [file join $path metaclass.tcl]]} {
    lappend loaded metaclass.tcl
    uplevel #0 [list source [file join $path metaclass.tcl]]
  }
  if {[file exists [file join $path baseclass.tcl]]} {
    lappend loaded baseclass.tcl
    uplevel #0 [list source [file join $path baseclass.tcl]]
  }
  foreach file $order {
    set file [file tail $file]
    if {$file in $loaded} continue
    if {![file exists [file join $path $file]]} {
      puts "WARNING [file join $path $file] does not exist in [info script]"
    } else {
      uplevel #0 [list source [file join $path $file]]
    }
    lappend loaded $file
  }
  foreach file [lsort -dictionary [glob -nocomplain [file join $path *.tcl]]] {
    if {[file tail $file] in $loaded} continue
    uplevel #0 [list source $file]
    lappend loaded [file tail $file]
  }
}

Added modules/tool/build/coroutine.tcl.



















































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
proc ::tool::define::coroutine {name corobody} {
  set class [current_class]
  ::oo::meta::info $class set method_ensemble ${name} _preamble: [list {} [string map [list %coroname% $name] {
    my variable coro_queue coro_lock
    set coro %coroname%
    set coroname [info object namespace [self]]::%coroname%
  }]]
  ::oo::meta::info $class set method_ensemble ${name} coroutine: {{} {
    return $coroutine
  }}
  ::oo::meta::info $class set method_ensemble ${name} restart: {{} {
    # Don't allow a coroutine to kill itself
    if {[info coroutine] eq $coroname} return
    if {[info commands $coroname] ne {}} {
      rename $coroname {}
    }
    set coro_lock($coroname) 0
    ::coroutine $coroname {*}[namespace code [list my $coro main]]
    ::cron::object_coroutine [self] $coroname
  }}
  ::oo::meta::info $class set method_ensemble ${name} kill: {{} {
    # Don't allow a coroutine to kill itself
    if {[info coroutine] eq $coroname} return
    if {[info commands $coroname] ne {}} {
      rename $coroname {}
    }
  }}

  ::oo::meta::info $class set method_ensemble ${name} main: [list {} $corobody]

  ::oo::meta::info $class set method_ensemble ${name} clear: {{} {
    set coro_queue($coroname) {}
  }}
  ::oo::meta::info $class set method_ensemble ${name} next: {{eventvar} {
    upvar 1 [lindex $args 0] event
    if {![info exists coro_queue($coroname)]} {
      return 1
    }
    if {[llength $coro_queue($coroname)] == 0} {
      return 1
    }
    set event [lindex $coro_queue($coroname) 0]
    set coro_queue($coroname) [lrange $coro_queue($coroname) 1 end]
    return 0
  }}
  
  ::oo::meta::info $class set method_ensemble ${name} peek: {{eventvar} {
    upvar 1 [lindex $args 0] event
    if {![info exists coro_queue($coroname)]} {
      return 1
    }
    if {[llength $coro_queue($coroname)] == 0} {
      return 1
    }
    set event [lindex $coro_queue($coroname) 0]
    return 0
  }}

  ::oo::meta::info $class set method_ensemble ${name} running: {{} {
    if {[info commands $coroname] eq {}} {
      return 0
    }
    if {[::cron::task exists $coroname]} {
      set info [::cron::task info $coroname]
      if {[dict exists $info running]} {
        return [dict get $info running]
      }
    }
    return 0
  }}
  
  ::oo::meta::info $class set method_ensemble ${name} send: {args {
    lappend coro_queue($coroname) $args
    if {[info coroutine] eq $coroname} {
      return
    }
    if {[info commands $coroname] eq {}} {
      ::coroutine $coroname {*}[namespace code [list my $coro main]]
      ::cron::object_coroutine [self] $coroname
    }
    if {[info coroutine] eq {}} {
      ::cron::do_one_event $coroname
    } else {
      yield
    }
  }}
  ::oo::meta::info $class set method_ensemble ${name} default: {args {my [self method] send $method {*}$args}}

}

Added modules/tool/build/ensemble.tcl.























































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
::namespace eval ::tool::define {}

if {![info exists ::tool::dirty_classes]} {
  set ::tool::dirty_classes {}
}

###
# Monkey patch oometa's rebuild function to
# include a notifier to tool
###
proc ::oo::meta::rebuild args {
  foreach class $args {
    if {$class ni $::oo::meta::dirty_classes} {
      lappend ::oo::meta::dirty_classes $class
    }
    if {$class ni $::tool::dirty_classes} {
      lappend ::tool::dirty_classes $class
    }
  }
}

proc ::tool::ensemble_build_map args {
  set emap {}
  foreach thisclass $args {
    foreach {ensemble einfo} [::oo::meta::info $thisclass getnull method_ensemble] {
      foreach {submethod subinfo} $einfo {
        dict set emap $ensemble $submethod $subinfo
      }
    }
  }
  return $emap
}

proc ::tool::ensemble_methods emap {
  set result {}
  foreach {ensemble einfo} $emap {
    #set einfo [dict getnull $einfo method_ensemble $ensemble]
    set eswitch {}
    set default standard
    if {[dict exists $einfo default:]} {
      set emethodinfo [dict get $einfo default:]
      set arglist     [lindex $emethodinfo 0]
      set realbody    [lindex $emethodinfo 1]
      if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} {
        set body {}
      } else {
        set body "\n      ::tool::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
      }
      append body "\n      " [string trim $realbody] "      \n"
      set default $body
      dict unset einfo default:
    }
    set methodlist {}
    foreach item [dict keys $einfo] {
      lappend methodlist [string trimright $item :]
    }
    set methodlist  [lsort -dictionary -unique $methodlist]
    foreach {submethod esubmethodinfo} [lsort -dictionary -stride 2 $einfo] {
      if {$submethod in {"_preamble:" "default:"}} continue
      set submethod [string trimright $submethod :]
      lassign $esubmethodinfo arglist realbody
      if {[string length [string trim $realbody]] eq {}} {
        dict set eswitch $submethod {}
      } else {
        if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} {
          set body {}
        } else {
          set body "\n      ::tool::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
        }
        append body "\n      " [string trim $realbody] "      \n"
        dict set eswitch $submethod $body
      }
    }
    if {![dict exists $eswitch <list>]} {
      dict set eswitch <list> {return $methodlist}
    }
    if {$default=="standard"} {
      set default "error \"unknown method $ensemble \$method. Valid: \$methodlist\""
    }
    dict set eswitch default $default
    set mbody {}    
    if {[dict exists $einfo _preamble:]} {
      append mbody [lindex [dict get $einfo _preamble:] 1] \n
    }
    append mbody \n [list set methodlist $methodlist]
    append mbody \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]"
    append mbody \n {return -options $opts $result}
    append result \n [list method $ensemble {{method default} args} $mbody]    
  }
  return $result
}

###
# topic: fb8d74e9c08db81ee6f1275dad4d7d6f
###
proc ::tool::dynamic_object_ensembles {thisobject thisclass} {
  variable trace
  set ensembledict {}
  foreach dclass $::tool::dirty_classes {
    foreach {cclass cancestors} [array get ::oo::meta::cached_hierarchy] {
      if {$dclass in $cancestors} {
        unset -nocomplain ::tool::obj_ensemble_cache($cclass)
      }
    }
  }
  set ::tool::dirty_classes {}
  ###
  # Only go through the motions for classes that have a locally defined
  # ensemble method implementation
  ###
  foreach aclass [::oo::meta::ancestors $thisclass] {
    if {[info exists ::tool::obj_ensemble_cache($aclass)]} continue
    set emap [::tool::ensemble_build_map $aclass]
    set body [::tool::ensemble_methods $emap]
    oo::define $aclass $body
    # Define a property for this ensemble for introspection
    foreach {ensemble einfo} $emap {
      ::oo::meta::info $aclass set ensemble_methods $ensemble: [lsort -dictionary [dict keys $einfo]]
    }
    set ::tool::obj_ensemble_cache($aclass) 1
  }
}

###
# topic: ec9ca249b75e2667ad5bcb2f7cd8c568
# title: Define an ensemble method for this agent
###
::proc ::tool::define::method {rawmethod args} {
  set class [current_class]
  set mlist [split $rawmethod "::"]
  if {[llength $mlist]==1} {
    ###
    # Simple method, needs no parsing
    ###
    set method $rawmethod
    ::oo::define $class method $rawmethod {*}$args
    return
  }
  set ensemble [lindex $mlist 0]
  set method [join [lrange $mlist 2 end] "::"]
  switch [llength $args] {
    1 {
      ::oo::meta::info $class set method_ensemble $ensemble $method: [list dictargs [lindex $args 0]]
    }
    2 {
      ::oo::meta::info $class set method_ensemble $ensemble $method: $args
    }
    default {
      error "Usage: method NAME ARGLIST BODY"
    }
  }
}

###
# topic: 354490e9e9708425a6662239f2058401946e41a1
# description: Creates a method which exports access to an internal dict
###
proc ::tool::define::dictobj args {
  dict_ensemble {*}$args
}
proc ::tool::define::dict_ensemble {methodname varname {cases {}}} {
  set class [current_class]
  set CASES [string map [list %METHOD% $methodname %VARNAME% $varname] $cases]
  
  set methoddata [::oo::meta::info $class getnull method_ensemble $methodname]
  set initial [dict getnull $cases initialize]
  variable $varname $initial
  foreach {name body} $CASES {
    dict set methoddata $name: [list args $body]
  }
  set template [string map [list %CLASS% $class %INITIAL% $initial %METHOD% $methodname %VARNAME% $varname] {
    _preamble {} {
      my variable %VARNAME%
    }
    add args {
      set field [string trimright [lindex $args 0] :]
      set data [dict getnull $%VARNAME% $field]
      foreach item [lrange $args 1 end] {
        if {$item ni $data} {
          lappend data $item
        }
      }
      dict set %VARNAME% $field $data
    }
    remove args {
      set field [string trimright [lindex $args 0] :]
      set data [dict getnull $%VARNAME% $field]
      set result {}
      foreach item $data {
        if {$item in $args} continue
        lappend result $item
      }
      dict set %VARNAME% $field $result
    }
    initial {} {
      return [dict rmerge [my meta branchget %VARNAME%] {%INITIAL%}]
    }
    reset {} {
      set %VARNAME% [dict rmerge [my meta branchget %VARNAME%] {%INITIAL%}]
      return $%VARNAME%
    }
    dump {} {
      return $%VARNAME%
    }
    append args {
      return [dict $method %VARNAME% {*}$args]
    }
    incr args {
      return [dict $method %VARNAME% {*}$args]
    }
    lappend args {
      return [dict $method %VARNAME% {*}$args]
    }
    set args {
      return [dict $method %VARNAME% {*}$args]
    }
    unset args {
      return [dict $method %VARNAME% {*}$args]
    }
    update args {
      return [dict $method %VARNAME% {*}$args]
    }
    branchset args {
      foreach {field value} [lindex $args end] {
        dict set %VARNAME% {*}[lrange $args 0 end-1] [string trimright $field :]: $value
      }
    }
    rmerge args {
      set %VARNAME% [dict rmerge $%VARNAME% {*}$args]
      return $%VARNAME%  
    }
    merge args {
      set %VARNAME% [dict rmerge $%VARNAME% {*}$args]
      return $%VARNAME%
    }
    replace args {
      set %VARNAME% [dict rmerge $%VARNAME% {%INITIAL%} {*}$args]
    }
    default args {
      return [dict $method $%VARNAME% {*}$args]
    }
  }]
  foreach {name arglist body} $template {
    if {[dict exists $methoddata $name:]} continue
    dict set methoddata $name: [list $arglist $body]
  }
  ::oo::meta::info $class set method_ensemble $methodname $methoddata
}

proc ::tool::define::arrayobj args {
  array_ensemble {*}$args
}

###
# topic: 354490e9e9708425a6662239f2058401946e41a1
# description: Creates a method which exports access to an internal array
###
proc ::tool::define::array_ensemble {methodname varname {cases {}}} {
  set class [current_class]
  set CASES [string map [list %METHOD% $methodname %VARNAME% $varname] $cases]
  set initial [dict getnull $cases initialize]
  array $varname $initial

  set map [list %CLASS% $class %METHOD% $methodname %VARNAME% $varname %CASES% $CASES %INITIAL% $initial]

  ::oo::define $class method _${methodname}Get {field} [string map $map {
    my variable %VARNAME%
    if {[info exists %VARNAME%($field)]} {
      return $%VARNAME%($field)
    }
    return [my meta getnull %VARNAME% $field:]
  }]
  ::oo::define $class method _${methodname}Exists {field} [string map $map {
    my variable %VARNAME%
    if {[info exists %VARNAME%($field)]} {
      return 1
    }
    return [my meta exists %VARNAME% $field:]
  }]
  set methoddata [::oo::meta::info $class set array_ensemble $methodname: $varname]
  
  set methoddata [::oo::meta::info $class getnull method_ensemble $methodname]
  foreach {name body} $CASES {
    dict set methoddata $name: [list args $body]
  } 
  set template  [string map [list %CLASS% $class %INITIAL% $initial %METHOD% $methodname %VARNAME% $varname] {
    _preamble {} {
      my variable %VARNAME%
    }
    reset {} {
      ::array unset %VARNAME% *
      foreach {field value} [my meta getnull %VARNAME%] {
        set %VARNAME%([string trimright $field :]) $value
      }
      ::array set %VARNAME% {%INITIAL%}
      return [array get %VARNAME%]
    }
    ni value {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      return [expr {$value ni $data}]
    }
    in value {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      return [expr {$value in $data}]
    }
    add args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      foreach item [lrange $args 1 end] {
        if {$item ni $data} {
          lappend data $item
        }
      }
      set %VARNAME%($field) $data
    }
    remove args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      set result {}
      foreach item $data {
        if {$item in $args} continue
        lappend result $item
      }
      set %VARNAME%($field) $result
    }
    dump {} {
      set result {}
      foreach {var val} [my meta getnull %VARNAME%] {
        dict set result [string trimright $var :] $val
      }
      foreach {var val} [lsort -dictionary -stride 2 [array get %VARNAME%]] {
        dict set result [string trimright $var :] $val
      }
      return $result
    }
    exists args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Exists $field]
    }
    getnull args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]      
    }
    get field {
      set field [string trimright $field :]
      set data [my _%METHOD%Get $field]
    }
    set args {
      set field [string trimright [lindex $args 0] :]
      ::set %VARNAME%($field) {*}[lrange $args 1 end]        
    }
    append args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      ::append data {*}[lrange $args 1 end]
      set %VARNAME%($field) $data
    }
    incr args {
      set field [string trimright [lindex $args 0] :]
      ::incr %VARNAME%($field) {*}[lrange $args 1 end]
    }
    lappend args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      $method data {*}[lrange $args 1 end]
      set %VARNAME%($field) $data
    }
    branchset args {
      foreach {field value} [lindex $args end] {
        set %VARNAME%([string trimright $field :]) $value
      }
    }
    rmerge args {
      foreach arg $args {
        my %VARNAME% branchset $arg
      }
    }
    merge args {
      foreach arg $args {
        my %VARNAME% branchset $arg
      }
    }
    default args {
      return [array $method %VARNAME% {*}$args]
    }
  }]
  foreach {name arglist body} $template {
    if {[dict exists $methoddata $name:]} continue
    dict set methoddata $name: [list $arglist $body]
  }
  ::oo::meta::info $class set method_ensemble $methodname $methoddata
}

Added modules/tool/build/event.tcl.





































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
###
# This file implements the Tool event manager
###

::namespace eval ::tool {}

::namespace eval ::tool::event {}

###
# topic: f2853d380a732845610e40375bcdbe0f
# description: Cancel a scheduled event
###
proc ::tool::event::cancel {self {task *}} {
  variable timer_event
  variable timer_script

  foreach {id event} [array get timer_event $self:$task] {
    ::after cancel $event
    set timer_event($id) {}
    set timer_script($id) {}
  }
}

###
# topic: 8ec32f6b6ba78eaf980524f8dec55b49
# description:
#    Generate an event
#    Adds a subscription mechanism for objects
#    to see who has recieved this event and prevent
#    spamming or infinite recursion
###
proc ::tool::event::generate {self event args} {
  set wholist [Notification_list $self $event]
  if {$wholist eq {}} return
  set dictargs [::oo::meta::args_to_options {*}$args]
  set info $dictargs
  set strict 0
  set debug 0
  set sender $self
  dict with dictargs {}
  dict set info id     [::tool::event::nextid]
  dict set info origin $self
  dict set info sender $sender
  dict set info rcpt   {}
  foreach who $wholist {
    catch {::tool::event::notify $who $self $event $info}
  }
}

###
# topic: 891289a24b8cc52b6c228f6edb169959
# title: Return a unique event handle
###
proc ::tool::event::nextid {} {
  return "event#[format %0.8x [incr ::tool::event_count]]"
}

###
# topic: 1e53e8405b4631aec17f98b3e8a5d6a4
# description:
#    Called recursively to produce a list of
#    who recieves notifications
###
proc ::tool::event::Notification_list {self event {stackvar {}}} {
  set notify_list {}
  foreach {obj patternlist} [array get ::tool::object_subscribe] {
    if {$obj eq $self} continue
    if {$obj in $notify_list} continue
    set match 0
    foreach {objpat eventlist} $patternlist {
      if {![string match $objpat $self]} continue
      foreach eventpat $eventlist {
        if {![string match $eventpat $event]} continue
        set match 1
        break
      }
      if {$match} {
        break
      }
    }
    if {$match} {
      lappend notify_list $obj
    }
  }
  return $notify_list
}

###
# topic: b4b12f6aed69f74529be10966afd81da
###
proc ::tool::event::notify {rcpt sender event eventinfo} {
  if {[info commands $rcpt] eq {}} return 
  if {$::tool::trace} {
    puts [list event notify rcpt $rcpt sender $sender event $event info $eventinfo]
  }
  $rcpt notify $event $sender $eventinfo
}

###
# topic: 829c89bda736aed1c16bb0c570037088
###
proc ::tool::event::process {self handle script} {
  variable timer_event
  variable timer_script

  array unset timer_event $self:$handle
  array unset timer_script $self:$handle

  set err [catch {uplevel #0 $script} result errdat]
  if $err {
    puts "BGError: $self $handle $script
ERR: $result
[dict get $errdat -errorinfo]
***"
  }
}

###
# topic: eba686cffe18cd141ac9b4accfc634bb
# description: Schedule an event to occur later
###
proc ::tool::event::schedule {self handle interval script} {
  variable timer_event
  variable timer_script
  if {$::tool::trace} {
    puts [list $self schedule $handle $interval]
  }
  if {[info exists timer_event($self:$handle)]} {
    if {$script eq $timer_script($self:$handle)} {
      return
    }
    ::after cancel $timer_event($self:$handle)
  }
  set timer_script($self:$handle) $script
  set timer_event($self:$handle) [::after $interval [list ::tool::event::process $self $handle $script]]
}

proc ::tool::event::sleep msec {
  ::cron::sleep $msec
}

###
# topic: e64cff024027ee93403edddd5dd9fdde
###
proc ::tool::event::subscribe {self who event} {
  upvar #0 ::tool::object_subscribe($self) subscriptions
  if {![info exists subscriptions]} {
    set subscriptions {}
  }
  set match 0
  foreach {objpat eventlist} $subscriptions {
    if {![string match $objpat $who]} continue      
    foreach eventpat $eventlist {
      if {[string match $eventpat $event]} {
        # This rule already exists
        return
      }
    }
  }
  dict lappend subscriptions $who $event
}

###
# topic: 5f74cfd01735fb1a90705a5f74f6cd8f
###
proc ::tool::event::unsubscribe {self args} {
  upvar #0 ::tool::object_subscribe($self) subscriptions
  if {![info exists subscriptions]} {
    return
  }  
  switch [llength $args] {
    1 {
      set event [lindex $args 0]
      if {$event eq "*"} {
        # Shortcut, if the 
        set subscriptions {}
      } else {
        set newlist {}
        foreach {objpat eventlist} $subscriptions {
          foreach eventpat $eventlist {
            if {[string match $event $eventpat]} continue
            dict lappend newlist $objpat $eventpat
          }
        }
        set subscriptions $newlist
      }
    }
    2 {
      set who [lindex $args 0]
      set event [lindex $args 1]
      if {$who eq "*" && $event eq "*"} {
        set subscriptions {}
      } else {
        set newlist {}
        foreach {objpat eventlist} $subscriptions {
          if {[string match $who $objpat]} {
            foreach eventpat $eventlist {
              if {[string match $event $eventpat]} continue
              dict lappend newlist $objpat $eventpat
            }
          }
        }
        set subscriptions $newlist
      }
    }
  }
}

::tool::define ::tool::object {
  ###
  # topic: 20b4a97617b2b969b96997e7b241a98a
  ###
  method event {submethod args} {
    ::tool::event::$submethod [self] {*}$args
  }
}

###
# topic: 37e7bd0be3ca7297996da2abdf5a85c7
# description: The event manager for Tool
###
namespace eval ::tool::event {
  variable nextevent {}
  variable nexteventtime 0
}

Added modules/tool/build/metaclass.tcl.



















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
#-------------------------------------------------------------------------
# TITLE: 
#    tool.tcl
#
# PROJECT:
#    tool: TclOO Helper Library
#
# DESCRIPTION:
#    tool(n): Implementation File
#
#-------------------------------------------------------------------------

namespace eval ::tool {}

###
# New OO Keywords for TOOL
###
namespace eval ::tool::define {}
proc ::tool::define::array {name {values {}}} {
  set class [current_class]
  set name [string trimright $name :]:
  if {![::oo::meta::info $class exists array $name]} {
    ::oo::meta::info $class set array $name {}
  }
  foreach {var val} $values {
    ::oo::meta::info $class set array $name: $var $val
  }
}

###
# topic: 710a93168e4ba7a971d3dbb8a3e7bcbc
###
proc ::tool::define::component {name info} {
  set class [current_class]
  ::oo::meta::info $class branchset component $name $info
}

###
# topic: 2cfc44a49f067124fda228458f77f177
# title: Specify the constructor for a class
###
proc ::tool::define::constructor {arglist rawbody} {
  set body {
::tool::object_create [self] [info object class [self]]
# Initialize public variables and options
my InitializePublic
  }
  append body $rawbody
  append body {
# Run "initialize"
my initialize
  }
  set class [current_class]
  ::oo::define $class constructor $arglist $body
}

###
# topic: 7a5c7e04989704eef117ff3c9dd88823
# title: Specify the a method for the class object itself, instead of for objects of the class
###
proc ::tool::define::class_method {name arglist body} {
  set class [current_class]
  ::oo::meta::info $class set class_typemethod $name: [list $arglist $body]
}

###
# topic: 4cb3696bf06d1e372107795de7fe1545
# title: Specify the destructor for a class
###
proc ::tool::define::destructor rawbody {
  set body {
# Run the destructor once and only once
set self [self]
my variable DestroyEvent
if {$DestroyEvent} return
set DestroyEvent 1
::tool::object_destroy $self
}
  append body $rawbody
  ::oo::define [current_class] destructor $body
}

###
# topic: 8bcae430f1eda4ccdb96daedeeea3bd409c6bb7a
# description: Add properties and option handling
###
proc ::tool::define::property args {
  set class [current_class]
  switch [llength $args] {
    2 {
      set type const
      set property [string trimleft [lindex $args 0] :]
      set value [lindex $args 1]
      ::oo::meta::info $class set $type $property: $value
      return
    }
    3 {
      set type     [lindex $args 0]
      set property [string trimleft [lindex $args 1] :]
      set value    [lindex $args 2]
      ::oo::meta::info $class set $type $property: $value
      return
    }
    default {
      error "Usage:
property name type valuedict
OR property name value"
    }
  }
  ::oo::meta::info $class set {*}$args
}

###
# topic: 615b7c43b863b0d8d1f9107a8d126b21
# title: Specify a variable which should be initialized in the constructor
# description:
#    This keyword can also be expressed:
#    [example {property variable NAME {default DEFAULT}}]
#    [para]
#    Variables registered in the variable property are also initialized
#    (if missing) when the object changes class via the [emph morph] method.
###
proc ::tool::define::variable {name {default {}}} {
  set class [current_class]
  set name [string trimright $name :]
  ::oo::meta::info $class set variable $name: $default
  ::oo::define $class variable $name
}

###
# Utility Procedures
###

# topic: 643efabec4303b20b66b760a1ad279bf
###
proc ::tool::args_to_dict args {
  if {[llength $args]==1} {
    return [lindex $args 0]
  }
  return $args
}

###
# topic: b40970b0d9a2525990b9105ec8c96d3d
###
proc ::tool::args_to_options args {
  set result {}
  foreach {var val} [args_to_dict {*}$args] {
    lappend result [string trimright [string trimleft $var -] :] $val
  }
  return $result
}

###
# topic: a92cd258900010f656f4c6e7dbffae57
###
proc ::tool::dynamic_methods class {
  ::oo::meta::rebuild $class
  set metadata [::oo::meta::metadata $class]
  foreach command [info commands [namespace current]::dynamic_methods_*] {
    $command $class $metadata
  }
}

###
# topic: 4969d897a83d91a230a17f166dbcaede
###
proc ::tool::dynamic_arguments {ensemble method arglist args} {
  set idx 0
  set len [llength $args]
  if {$len > [llength $arglist]} {
    ###
    # Catch if the user supplies too many arguments
    ###
    set dargs 0
    if {[lindex $arglist end] ni {args dictargs}} {
      return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
    }
  }
  foreach argdef $arglist {
    if {$argdef eq "args"} {
      ###
      # Perform args processing in the style of tcl
      ###
      uplevel 1 [list set args [lrange $args $idx end]]
      break
    }
    if {$argdef eq "dictargs"} {
      ###
      # Perform args processing in the style of tcl
      ###
      uplevel 1 [list set args [lrange $args $idx end]]
      ###
      # Perform args processing in the style of tool
      ###
      set dictargs [::tool::args_to_options {*}[lrange $args $idx end]]
      uplevel 1 [list set dictargs $dictargs]
      break
    }
    if {$idx > $len} {
      ###
      # Catch if the user supplies too few arguments
      ###
      if {[llength $argdef]==1} {
        return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
      } else {
        uplevel 1 [list set [lindex $argdef 0] [lindex $argdef 1]]
      }
    } else {
      uplevel 1 [list set [lindex $argdef 0] [lindex $args $idx]]
    }
    incr idx
  }
}

###
# topic: b88add196bb63abccc44639db5e5eae1
###
proc ::tool::dynamic_methods_class {thisclass metadata} {
  foreach {method info} [dict getnull $metadata class_typemethod] {
    lassign $info arglist body
    set method [string trimright $method :]
    ::oo::objdefine $thisclass method $method $arglist $body
  }
}

###
# topic: 53ab28ac5c6ee601fe1fe07b073be88e
###
proc ::tool::dynamic_wrongargs_message {arglist} {
  set result ""
  set dargs 0
  foreach argdef $arglist {
    if {$argdef in {args dictargs}} {
      set dargs 1
      break
    }
    if {[llength $argdef]==1} {
      append result " $argdef"
    } else {
      append result " ?[lindex $argdef 0]?"
    }
  }
  if { $dargs } {
    append result " ?option value?..."
  }
  return $result
}

proc ::tool::object_create {objname {class {}}} {
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    set ${varname}($objname) {}
  }
  if {$class eq {}} {
    set class [info object class $objname]
  }
   set object_info($objname) [list class $class]
  if {$class ne {}} {
    $objname graft class $class
    foreach command [info commands [namespace current]::dynamic_object_*] {
      $command $objname $class
    }
  }
}


proc ::tool::object_rename {object newname} {
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    if {[info exists ${varname}($object)]} {
      set ${varname}($newname) [set ${varname}($object)]
      unset ${varname}($object)
    }
  }
  variable coroutine_object
  foreach {coro coro_objname} [array get coroutine_object] {
    if { $object eq $coro_objname } {
      set coroutine_object($coro) $newname
    }
  }
  rename $object ::[string trimleft $newname]
  ::tool::event::generate $object object_rename [list newname $newname]
}

proc ::tool::object_destroy objname {
  ::tool::event::generate $objname object_destroy [list objname $objname]
  ::tool::event::cancel $objname *
  ::cron::object_destroy $objname
  variable coroutine_object
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    unset -nocomplain ${varname}($objname)
  }
}

#-------------------------------------------------------------------------
# Option Handling Mother of all Classes

# tool::object
#
# This class is inherited by all classes that have options.
#

::tool::define ::tool::object {
  # Put MOACish stuff in here
  variable signals_pending create
  variable organs {}
  variable mixins {}
  variable mixinmap {}
  variable DestroyEvent 0

  constructor args {
    my Config_merge [::tool::args_to_options {*}$args]
  }
  
  destructor {}
    
  method ancestors {{reverse 0}} {
    set result [::oo::meta::ancestors [info object class [self]]]
    if {$reverse} {
      return [lreverse $result]
    }
    return $result
  }
  
  method DestroyEvent {} {
    my variable DestroyEvent
    return $DestroyEvent
  }
  
  ###
  # title: Forward a method
  ###
  method forward {method args} {
    oo::objdefine [self] forward $method {*}$args
  }
  
  ###
  # title: Direct a series of sub-functions to a seperate object
  ###
  method graft args {
    my variable organs
    if {[llength $args] == 1} {
      error "Need two arguments"
    }
    set object {}
    foreach {stub object} $args {
      if {$stub eq "class"} {
        # Force class to always track the object's current class
        set obj [info object class [self]]
      }
      dict set organs $stub $object
      oo::objdefine [self] forward <${stub}> $object
      oo::objdefine [self] export <${stub}>
    }
    return $object
  }
  
  # Called after all options and public variables are initialized
  method initialize {} {}
  
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  method InitializePublic {} {
    my variable config meta
    if {![info exists meta]} {
      set meta {}
    }
    if {![info exists config]} {
      set config {}
    }
    my ClassPublicApply {}
  }
  
  class_method info {which} {
    my variable cache
    if {![info exists cache($which)]} {
      set cache($which) {}
      switch $which {
        public {
          dict set cache(public) variable [my meta branchget variable]
          dict set cache(public) array [my meta branchget array]
          set optinfo [my meta getnull option]
          dict set cache(public) option_info $optinfo
          foreach {var info} [dict getnull $cache(public) option_info] {
            if {[dict exists $info aliases:]} {
              foreach alias [dict exists $info aliases:] {
                dict set cache(public) option_canonical $alias $var
              }
            }
            set getcmd [dict getnull $info default-command:]
            if {$getcmd ne {}} {
              dict set cache(public) option_default_command $var $getcmd
            } else {
              dict set cache(public) option_default_value $var [dict getnull $info default:]
            }
            dict set cache(public) option_canonical $var $var
          }
        }
      }
    }
    return $cache($which)
  }
  
  ###
  # Incorporate the class's variables, arrays, and options
  ###
  method ClassPublicApply class {
    my variable config
    set integrate 0
    if {$class eq {}} {
      set class [info object class [self]]      
    } else {
      set integrate 1
    }
    set public [$class info public]
    foreach {var value} [dict getnull $public variable] {
      if { $var in {meta config} } continue
      my variable $var
      if {![info exists $var]} {
        set $var $value
      }
    }
    foreach {var value} [dict getnull $public array] {
      if { $var eq {meta config} } continue
      my variable $var
      foreach {f v} $value {
        if {![array exists ${var}($f)]} {
          set ${var}($f) $v
        }
      }
    }
    set dat [dict getnull $public option_info]
    if {$integrate} {
      my meta rmerge [list option $dat]
    }
    my variable option_canonical
    array set option_canonical [dict getnull $public option_canonical]
    set dictargs {}
    foreach {var getcmd} [dict getnull $public option_default_command] {
      if {[dict getnull $dat $var class:] eq "organ"} {
        if {[my organ $var] ne {}} continue
      }
      if {[dict exists $config $var]} continue
      dict set dictargs $var [{*}[string map [list %field% $var %self% [namespace which my]] $getcmd]]
    }
    foreach {var value} [dict getnull $public option_default_value] {
      if {[dict getnull $dat $var class:] eq "organ"} {
        if {[my organ $var] ne {}} continue
      }
      if {[dict exists $config $var]} continue
      dict set dictargs $var $value
    }
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {
      if {[dict exists $config $field]} continue
      set script [dict getnull $dat $field set-command:]
      dict set config $field $val
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
  }
  
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  method mixin args {
    ###
    # Mix in the class
    ###
    my variable mixins
    set prior $mixins

    set mixins $args
    ::oo::objdefine [self] mixin {*}$args
    ###
    # Build a compsite map of all ensembles defined by the object's current
    # class as well as all of the classes being mixed in
    ###
    set emap [::tool::ensemble_build_map [::info object class [self]] {*}[lreverse $args]]
    set body [::tool::ensemble_methods $emap]
    oo::objdefine [self] $body
    foreach class $args {
      if {$class ni $prior} {
        my meta mixin $class
      }
      my ClassPublicApply $class
    }
    foreach class $prior {
      if {$class ni $mixins } { 
        my meta mixout $class
      }
    }
  }

  method mixinmap args { 
    my variable mixinmap
    set priorlist {}
    foreach {slot classes} $args {
      if {[dict exists $mixinmap $slot]} {
        lappend priorlist {*}[dict get $mixinmap $slot]  
        foreach class [dict get $mixinmap $slot] {
          if {$class ni $classes && [$class meta exists mixin unmap-script:]} {
            if {[catch [$class meta get mixin unmap-script:] err errdat]} {
              puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]"
            }
          }
        }
      }
      dict set mixinmap $slot $classes
    }
    my Recompute_Mixins
    foreach {slot classes} $args {
      foreach class $classes {
        if {$class ni $priorlist && [$class meta exists mixin map-script:]} {
          if {[catch [$class meta get mixin map-script:] err errdat]} {
            puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]"
          }
        }
      }
    }
    foreach {slot classes} $mixinmap {
      foreach class $classes {
        if {[$class meta exists mixin react-script:]} {
          if {[catch [$class meta get mixin react-script:] err errdat]} {
            puts stderr "[self] MIXIN ERROR REACTING $class:\n[dict get $errdat -errorinfo]"
          }
        }
      }
    }
  }

  method debug_mixinmap {} {
    my variable mixinmap
    return $mixinmap
  }

  method Recompute_Mixins {} {
    my variable mixinmap
    set classlist {}
    foreach {item class} $mixinmap {
      if {$class ne {}} {
        lappend classlist $class
      }
    }
    my mixin {*}$classlist
  }
  
  method morph newclass {
    if {$newclass eq {}} return
    set class [string trimleft [info object class [self]]]
    set newclass [string trimleft $newclass :]
    if {[info command ::$newclass] eq {}} {
      error "Class $newclass does not exist"
    }
    if { $class ne $newclass } {
      my Morph_leave
      my variable mixins
      oo::objdefine [self] class ::${newclass}
      my graft class ::${newclass}
      # Reapply mixins
      my mixin {*}$mixins
      my InitializePublic
      my Morph_enter
    }
  }

  ###
  # Commands to perform as this object transitions out of the present class
  ###
  method Morph_leave {} {}
  ###
  # Commands to perform as this object transitions into this class as a new class
  ###
  method Morph_enter {} {}
  
  ###
  # title: List which objects are forwarded as organs
  ###
  method organ {{stub all}} {
    my variable organs
    if {![info exists organs]} {
      return {}
    }
    if { $stub eq "all" } {
      return $organs
    }
    return [dict getnull $organs $stub]
  }
}


Added modules/tool/build/option.tcl.











































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
###
# topic: 68aa446005235a0632a10e2a441c0777
# title: Define an option for the class
###
proc ::tool::define::option {name args} {
  set class [current_class]
  set dictargs {default: {}}
  foreach {var val} [::oo::meta::args_to_dict {*}$args] {
    dict set dictargs [string trimright [string trimleft $var -] :]: $val
  }
  set name [string trimleft $name -]

  ###
  # Option Class handling
  ###
  set optclass [dict getnull $dictargs class:]
  if {$optclass ne {}} {
    foreach {f v} [::oo::meta::info $class getnull option_class $optclass] {
      if {![dict exists $dictargs $f]} {
        dict set dictargs $f $v
      }
    }
    if {$optclass eq "variable"} {
      variable $name [dict getnull $dictargs default:]
    }
  }
  ::oo::meta::info $class branchset option $name $dictargs
}

###
# topic: 827a3a331a2e212a6e301f59c1eead59
# title: Define a class of options
# description:
#    Option classes are a template of properties that other
#    options can inherit.
###
proc ::tool::define::option_class {name args} {
  set class [current_class]
  set dictargs {default {}}
  foreach {var val} [::oo::meta::args_to_dict {*}$args] {
    dict set dictargs [string trimleft $var -] $val
  }
  set name [string trimleft $name -]
  ::oo::meta::info $class branchset option_class $name $dictargs
}

::tool::define ::tool::object {
  property options_strict 0
  variable organs {}

  option_class organ {
    widget label
    set-command {my graft %field% %value%}
    get-command {my organ %field%}
  }

  option_class variable {
    widget entry
    set-command {my variable %field% ; set %field% %value%}
    get-command {my variable %field% ; set %field%}
  }
  
  dict_ensemble config config {
    get {
      return [my Config_get {*}$args]
    }
    merge {
      return [my Config_merge {*}$args]
    }
    set {
      my Config_set {*}$args
    }
  }

  ###
  # topic: 86a1b968cea8d439df87585afdbdaadb
  ###
  method cget args {
    return [my Config_get {*}$args]
  }

  ###
  # topic: 73e2566466b836cc4535f1a437c391b0
  ###
  method configure args {
    # Will be removed at the end of "configurelist_triggers"
    set dictargs [::oo::meta::args_to_options {*}$args]
    if {[llength $dictargs] == 1} {
      return [my cget [lindex $dictargs 0]]
    }
    set dat [my Config_merge $dictargs]
    my Config_triggers $dat
  }

  method Config_get {field args} {
    my variable config option_canonical option_getcmd
    set field [string trimleft $field -]
    if {[info exists option_canonical($field)]} {
      set field $option_canonical($field)
    }
    if {[info exists option_getcmd($field)]} {
      return [eval $option_getcmd($field)]
    }
    if {[dict exists $config $field]} {
      return [dict get $config $field]
    }
    if {[llength $args]} {
      return [lindex $args 0]
    }
    return [my meta cget $field] 
  }
  
  ###
  # topic: dc9fba12ec23a3ad000c66aea17135a5
  ###
  method Config_merge dictargs {
    my variable config option_canonical
    set rawlist $dictargs
    set dictargs {}
    set dat [my meta getnull option]
    foreach {field val} $rawlist {
      set field [string trimleft $field -]
      set field [string trimright $field :]
      if {[info exists option_canonical($field)]} {
        set field $option_canonical($field)
      }
      dict set dictargs $field $val
    }
    ###
    # Validate all inputs
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field validate-command:]
      if {$script ne {}} {
        dict set dictargs $field [eval [string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]]
      }
    }
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field set-command:]
      dict set config $field $val
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
    return $dictargs
  }
  
  method Config_set args {
    set dictargs [::tool::args_to_options {*}$args]
    set dat [my Config_merge $dictargs]
    my Config_triggers $dat
  }
  
  ###
  # topic: 543c936485189593f0b9ed79b5d5f2c0
  ###
  method Config_triggers dictargs {
    set dat [my meta getnull option]
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field post-command:]
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
  }

  method Option_Default field {
    set info [my meta getnull option $field]
    set getcmd [dict getnull $info default-command:]
    if {$getcmd ne {}} {
      return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
    } else {
      return [dict getnull $info default:]
    }
  }
}

package provide tool::option 0.1

Added modules/tool/build/organ.tcl.

































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
###
# A special class of objects that
# stores no meta data of its own
# Instead it vampires off of the master object
###
tool::class create ::tool::organelle {
  
  constructor {master} {
    my entangle $master
    set final_class [my select]
    if {[info commands $final_class] ne {}} {
      # Safe to switch class here, we haven't initialized anything
      oo::objdefine [self] class $final_class
    }
    my initialize
  }

  method entangle {master} {
    my graft master $master
    my forward meta $master meta
    foreach {stub organ} [$master organ] {
      my graft $stub $organ
    }
    foreach {methodname variable} [my meta branchget array_ensemble] {
      my forward $methodname $master $methodname
    }
  }
  
  method select {} {
    return {}
  }
}

Added modules/tool/build/pipeline.tcl.















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
::namespace eval ::tool::signal {}
::namespace eval ::tao {}

# Provide a backward compatible hook
proc ::tool::main {} {
  ::cron::main
}

proc ::tool::do_events {} {
  ::cron::do_events
}

proc ::tao::do_events {} {
  ::cron::do_events
}

proc ::tao::main {} {
  ::cron::main
}


package provide tool::pipeline 0.1

Added modules/tool/build/script.tcl.









































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
###
# Add configure by script facilities to TOOL
###
::tool::define ::tool::object {

  ###
  # Allows for a constructor to accept a psuedo-code
  # initialization script which exercise the object's methods
  # sans "my" in front of every command
  ###
  method Eval_Script script {
    set buffer {}
    set thisline {}
    foreach line [split $script \n] {
      append thisline $line
      if {![info complete $thisline]} {
        append thisline \n
        continue
      }
      set thisline [string trim $thisline]
      if {[string index $thisline 0] eq "#"} continue
      if {[string length $thisline]==0} continue
      if {[lindex $thisline 0] eq "my"} {
        # Line already calls out "my", accept verbatim
        append buffer $thisline \n
      } elseif {[string range $thisline 0 2] eq "::"} {
        # Fully qualified commands accepted verbatim
        append buffer $thisline \n
      } elseif {
        append buffer "my $thisline" \n
      }
      set thisline {}
    }
    eval $buffer
  }
}

Added modules/tool/build/uuid.tcl.













































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
::namespace eval ::tool {}

proc ::tool::is_null value {
  return [expr {$value in {{} NULL}}]
}


proc ::tool::uuid_seed args {
  if {[llength $args]==0 || ([llength $args]==1 && [is_null [lindex $args 0]])} {
    if {[info exists ::env(USERNAME)]} {
      set user $::env(USERNAME)
    } elseif {[info exists ::env(USER)]} {
      set user $::env(USER)
    } else {
      set user $::env(user)
    }
    incr ::tool::nextuuid $::tool::globaluuid
    set ::tool::UUID_Seed [list user@[info hostname] [clock format [clock seconds]]]
  } else {
    incr ::tool::globaluuid $::tool::nextuuid
    set ::tool::nextuuid 0
    set ::tool::UUID_Seed $args
  }
}

###
# topic: 0a19b0bfb98162a8a37c1d3bbfb8bc3d
# description:
#    Because the tcllib version of uuid generate requires
#    network port access (which can be slow), here's a fast
#    and dirty rendition
###
proc ::tool::uuid_generate args {
  if {![llength $args]} {
    set block [list [incr ::tool::nextuuid] {*}$::tool::UUID_Seed]
  } else {
    set block $args
  }
  return [::sha1::sha1 -hex [join $block ""]]
}

###
# topic: ee3ec43cc2cc2c7d6cf9a4ef1c345c19
###
proc ::tool::uuid_short args {
  if {![llength $args]} {
    set block [list [incr ::tool::nextuuid] {*}$::tool::UUID_Seed]
  } else {
    set block $args
  }
  return [string range [::sha1::sha1 -hex [join $block ""]] 0 16]
}

###
# topic: b14c505537274904578340ec1bc12af1
# description:
#    Implementation the uses a compiled in ::md5 implementation
#    commonly used by embedded application developers
###
namespace eval ::tool {
  namespace export *
}
###
# Cache the bits of the UUID seed that aren't likely to change
# once the software is loaded, but which can be expensive to
# generate
###
set ::tool::nextuuid 0
set ::tool::globaluuid 0
::tool::uuid_seed

Added modules/tool/meta.man.











































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
[comment {-*- tcl -*- doctools manpage}]
[vset OOUTIL_VERSION 1.2.2]
[manpage_begin oo::util n [vset OOUTIL_VERSION]]
[see_also snit(n)]
[keywords callback]
[keywords {class methods}]
[keywords {class variables}]
[keywords {command prefix}]
[keywords currying]
[keywords {method reference}]
[keywords {my method}]
[keywords singleton]
[keywords TclOO]
[copyright {2011-2015 Andreas Kupries, BSD licensed}]
[moddesc {Utility commands for TclOO}]
[titledesc {Utility commands for TclOO}]
[category  Utility]
[require Tcl 8.5]
[require TclOO]
[require oo::util [opt [vset OOUTIL_VERSION]]]
[description]
[para]

This package provides a convenience command for the easy specification
of instance methods as callback commands, like timers, file events, Tk
bindings, etc.

[section {COMMANDS}]

[list_begin definitions]
[comment {- - -- --- ----- -------- ------------- ---------------------}]
[call [cmd mymethod] [arg method] [opt [arg arg]...]]

This command is available within instance methods. It takes a method
name and, possibly, arguments for the method and returns a command
prefix which, when executed, will invoke the named method of the
object we are in, with the provided arguments, and any others supplied
at the time of actual invokation.

[para] Note: The command is equivalent to and named after the command
provided by the OO package [package snit] for the same purpose.

[comment {- - -- --- ----- -------- ------------- ---------------------}]
[call [cmd classmethod] [arg name] [arg arguments] [arg body]]

This command is available within class definitions. It takes a method
name and, possibly, arguments for the method and creates a method on the
class, available to a user of the class and of derived classes.

[para] Note: The command is equivalent to the command [cmd typemethod]
provided by the OO package [package snit] for the same purpose.

[para] Example
[example {
oo::class create ActiveRecord {
    classmethod find args { puts "[self] called with arguments: $args" }
}
oo::class create Table {
    superclass ActiveRecord
}
puts [Table find foo bar]
# ======
# which will write
# ======
# ::Table called with arguments: foo bar
}]

[comment {- - -- --- ----- -------- ------------- ---------------------}]
[call [cmd classvariable] [opt [arg arg]...]]

This command is available within instance methods. It takes a series
of variable names and makes them available in the method's scope. The
originating scope for the variables is the class (instance) the object
instance belongs to. In other words, the referenced variables are shared
between all instances of their class.

[para] Note: The command is roughly equivalent to the command
[cmd typevariable] provided by the OO package [package snit] for the
same purpose. The difference is that it cannot be used in the class
definition itself.

[para] Example:
[example {
% oo::class create Foo {
    method bar {z} {
        classvariable x y
        return [incr x $z],[incr y]
    }
}
::Foo
% Foo create a
::a
% Foo create b
::b
% a bar 2
2,1
% a bar 3
5,2
% b bar 7
12,3
% b bar -1
11,4
% a bar 0
11,5
}]

[comment {- - -- --- ----- -------- ------------- ---------------------}]
[call [cmd link] [arg method]...]
[call [cmd link] "{[arg alias] [arg method]}..."]

This command is available within instance methods. It takes a list of
method names and/or pairs of alias- and method-name and makes the
named methods available to all instance methods without requiring the
[cmd my] command.

[para] The alias name under which the method becomes available defaults
to the method name, except where explicitly specified through an
alias/method pair.

[para] Examples:
[example {
    link foo
    # The method foo is now directly accessible as foo instead of my foo.

    link {bar foo}
    # The method foo is now directly accessible as bar.

    link a b c
    # The methods a, b, and c all become directly acessible under their
    # own names.
}]

The main use of this command is expected to be in instance constructors,
for convenience, or to set up some methods for use in a mini DSL.

[comment {- - -- --- ----- -------- ------------- ---------------------}]
[call [cmd ooutil::singleton] [opt [arg arg]...]]

This command is a meta-class, i.e. a variant of the builtin
[cmd oo::class] which ensures that it creates only a single
instance of the classes defined with it.

[para] Syntax and results are like for [cmd oo::class].

[para] Example:
[example {
% oo::class create example {
   self mixin singleton
   method foo {} {self}
}
::example
% [example new] foo
::oo::Obj22
% [example new] foo
::oo::Obj22
}]

[list_end]

[section AUTHORS]
Donal Fellows, Andreas Kupries

[vset CATEGORY oo::util]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

Added modules/tool/module.shed.

















>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
my shed set name: tool
my shed set origin: http://fossil.etoyoc.com/fossil/tool
my shed set description: {
The base of the TOOL framework
}
foreach file [glob -nocomplain [file join $dir *]] {
  my scan $file {class: source}
}

Added modules/tool/pkgIndex.tcl.



























>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded tool 0.7 [list source [file join $dir tool.tcl]]

Added modules/tool/tool.demo.



































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
set here [file dirname [file join [pwd] [info script]]]
puts LOADING
source [file join $here .. oodialect oodialect.tcl]
source [file join $here .. dicttool dicttool.tcl]
source [file join $here .. oometa oometa.tcl]
source [file join $here .. sha1 sha1.tcl]

source [file join $here index.tcl]

tool::class create foo {
  option color {default blue}
}

puts "START DEMO"
foo create bar
puts [bar cget color]
bar configure color green
puts [bar cget color]


tool::class create car {
  option color {
    default: white
  }
  variable location home
  array physics {
    speed 0
    accel 0
    position {0 0}
  }

  method physics {field args} {
    my variable physics
    if {[llength $args]} {
      set physics($field) $args
    }
    return $physics($field)
  }
  method location {} {
    my variable location
    return $location
  }
  method move newloc {
    my variable location
    set location $newloc
  }
}

car create car1 color green
car1 cget color
#> green
car create car2
car2 cget color
#> white

car1 location
#> home
car1 move work
car1 location
#> work
puts [car1 physics speed]
#> 0
car1 physics speed 10
puts [car1 physics speed]
#> 10

Added modules/tool/tool.man.

























































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin tool n 0.4.2]
[keywords TOOL]
[copyright {2015 Sean Woods <yoda@etoyoc.com>}]
[moddesc   {Standardized OO Framework for development}]
[titledesc {TclOO Library (TOOL) Framework}]
[category TclOO]
[keywords TclOO]
[keywords framework]
[require Tcl 8.6]
[require sha1]
[require dicttool]
[require oo::meta]
[require oo::dialect]
[description]
[para]
This module implements the Tcl Object Oriented Library framework, or [emph TOOL]. It is
intended to be a general purpose framework that is useable in its own right, and
easily extensible.
[para]
TOOL defines a metaclass with provides several additional keywords to the TclOO
description langauge, default behaviors for its consituent objects, and
top-down integration with the capabilities provided by the [package oo::meta] package.
[para]
The TOOL metaclass was build with the [package oo::dialect] package, and thus can
be used as the basis for additional metaclasses. As a metaclass, TOOL has it's own
"class" class, "object" class, and define namespace.
[example {
package require tool

# tool::class workds just like oo::class
tool::class create myclass {
}

# tool::define works just like oo::define
tool::define myclass method noop {} {}

# tool::define and tool::class understand additional keywords
tool::define myclass array_ensemble mysettings mysettings {}

# And tool interoperates with oo::define
oo::define myclass method do_something {} { return something }

# TOOL and TclOO objects are interchangeable
oo::class create myooclass {
  superclass myclass
}
}]
[para]
Several manual pages go into more detail about specific keywords and methods.
[list_begin definitions]
[def [package tool::array_ensemble]]
[def [package tool::dict_ensemble]]
[def [package tool::method_ensemble]]
[def [package tool::object]]
[def [package tool::option_handling]]
[list_end]

[section Keywords]
TOOL adds new (or modifies) keywords used in the definitions of classes. However,
the new keywords are only available via calls to [emph {tool::class create}] or [emph tool::define]

[list_begin definitions]

[call tool::define [cmd class_method] [arg arglist] [arg body]]
Defines a method for the class object itself. This method will be passed on to descendents of the class,
unlike [cmd {self method}].

[call tool::define [cmd array] [arg name] [arg contents]]

Declares a variable [arg name] which will be initialized as an array, populated with [arg contents] for objects of this class, as well as any
objects for classes which are descendents of this class.

[call tool::define [cmd array_ensemble] [arg methodname] [arg varname] [opt cases]]

Declares a method ensemble [arg methodname] which will control access to variable
[arg varname]. Cases are a key/value list of method names and bodies which will be
overlaid on top of the standard template. See [package tool::array_ensemble].
[para]
One method name is reserved: [cmd initialize]. [cmd initialize] Declares the initial values to be populated in the array, as a key/value list,
and will not be expressed as a method for the ensemble.

[call tool::define [cmd dict_ensemble] [arg methodname] [arg varname] [opt cases]]

Declares a method ensemble [arg methodname] which will control access to variable
[arg varname]. Cases are a key/value list of method names and bodies which will be
overlaid on top of the standard template. See [package tool::dict_ensemble].
[para]
One method name is reserved: [cmd initialize]. [cmd initialize] Declares the initial values to be populated in the array, as a key/value list,
and will not be expressed as a method for the ensemble.

[call tool::define [cmd method] [arg methodname] [arg arglist] [arg body]]

If [arg methodname] contains ::, the method is considered to be
part of a method ensemble. See [package tool::method_ensembles]. Otherwise
this command behaves exactly like the standard [namespace oo::define] [cmd method]
command.


[call tool::define [cmd option] [arg name] [arg dictopts]]

Declares an option. [arg dictopts] is a key/value list defining parameters for the option. See [package tool::option_handling].

[example {
tool::class create myclass {
  option color {
    post-command: {puts [list %self%'s %field% is now %value%]}
    default: green
  }
}
myclass create foo
foo configure color purple
> foo's color is now purple
}]

[call tool::define [cmd property] [opt branch] [arg field] [arg value]]

Defines a new leaf in the class metadata tree. With no branch, the
leaf will appear in the [emph const] section, accessible by either the
object's [cmd property] method, or via [cmd oo::meta::info] [emph class] [cmd {get const}] [emph field]:

[call tool::define [cmd variable] [arg name] [arg value]]

Declares a variable [arg name] which will be initialized with the value [arg value] for objects of this class, as well as any
objects for classes which are descendents of this class.

[list_end]

[section {Public Object Methods}]

The TOOL object mother of all classes defines several methods to enforces consistent
behavior throughout the framework.

[list_begin definitions]

[call [emph object] [cmd cget] [arg option]]

Return the value of this object's option [arg option]. If the [cmd {property options_strict}] is true
for this class, calling an option which was not declared by the [cmd option] keyword will throw
an error. In all other cases if the value is present in the object's [emph options] array that
value is returned. If it does not exist, the object will attempt to retrieve a property of the same
name.

[call [emph object] [cmd configure] [opt keyvaluelist]]
[call [emph object] [cmd configure] [arg field] [arg value] [opt field] [opt value] [opt ...]]

This command will inject new values into the objects [emph options] array, according to the rules
as set forth by the option descriptions. See [package tool::option_handling] for details.

[cmd configure] will strip leading -'s off of field names, allowing it to behave in a quasi-backward
compatible manner to tk options.

[call [emph object] [cmd configurelist] [opt keyvaluelist]]

This command will inject new values into the objects [emph options] array, according to the rules
as set forth by the option descriptions. This command will perform validation and alternate storage
rules. It will not invoke trigger rules. See [package tool::option_handling] for details.

[call [emph object] [cmd forward] [arg stub] [arg forward]]

A passthrough to [cmd {oo:objdefine [self] forward}]

[call [emph object] [cmd graft] [arg stub] [arg forward]]

Delegates the [arg <stub>] method to the object or command designated by [arg forward]

[example {
tool::object create A
tool::object create B
A graft buddy B
A configure color red
B configure color blue
A cget color
> red
A <buddy> cget color
> blue
}]

[list_end]

[section {Private Object Methods}]
[list_begin definitions]
[call [emph object] [cmd InitializePublic]]
Consults the metadata for the class to ensure every array, option, and variable
which has been declared but not initialized is initialized with the default value.

This method is called by the constructor and the morph method. It is safe to
invoke multiple times.

[call [emph object] [cmd Eval_Script] [opt script]]
Executes a block of text within the namespace of the object. Lines that
begin with a # are ignored as comments. Commands
that begin with :: are interpreted as calling a global command. All other
Tcl commands that lack a "my" prefix are given one, to allow the script
to exercise internal methods. This method is intended for configuration scripts,
where the object's methods are intepreting a domain specific language.

[example {
tool::class myclass {
  constructor script {
    my Eval_Script $script
  }
  method node {nodename info} {
    my variable node
    dict set node $nodename $info
  }
  method get {args} {
    my variable node
    return [dict get $node $args]
  }
}
myclass create movies {
  # This block of code is executed by the object
  node {The Day the Earth Stood Still} {
    date: 1952
    characters: {GORT Klatoo}
  }
}
movies get {The Day the Earth Stood Still} date:
> 1952
}]

[call [emph object] [cmd Option_Default] [arg field]]

Computes the default value for an option. See [package tool::option_handling].

[list_end]

[section AUTHORS]
Sean Woods

[vset CATEGORY tcloo]
[include ../doctools2base/include/feedback.inc]
[manpage_end]


Added modules/tool/tool.md.



























































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
Module: TOOL
============

TOOL is the Tcl Object Oriented Library, a standard object framework. TOOL
implements common design patterns in a standardized, tested, and documented
manner. 

# Major Concepts

* Metadata Interitance
* Variable and Array Initialization
* Option handling
* Delegation
* Method Ensembles

## Using TOOL

Tool is accessed from the "tool" package:

<pre><code>
package require tool
</code></pre>

## Metadata Interitance

TOOL builds on the oo::meta package to allow data and configuration to be
passed along to descendents in the same way methods are.

<pre><code>tool::class create fruit {
  property taste sweet
}
tool::class create fruit.apple {
  property color red
}
tool::class create fruit.orange {
  property color orange
}
fruit.orange create cutie
cutie property color
> orange
cutie property taste
> sweet
</code></pre>

## Variable and Array Initialization

TOOL modifies the *variable* keyword and adds and *array* keyword. Using
either will cause a variable of the given name to be initialized with the
given value for this class AND any descendents.

<pre><code>tool::class create car {
  option color {
    default: white
  }
  variable location home
  array physics {
    speed 0
    accel 0
    position {0 0}
  }

  method physics {field args} {
    my variable physics
    if {[llength $args]} {
      set physics($field) $args
    }
    return $physics($field)
  }
  method location {} {
    my variable location
    return $location
  }
  method move newloc {
    my variable location
    set location $newloc
  }
}

car create car1 color green
car1 cget color
> green
car create car2
car2 cget color
> white

car1 location
> home
car1 move work
car1 location
> work
car1 physics speed
> 0
car1 physics speed 10
car1 physics speed
> 10
</code></pre>

## Delegation

TOOL is built around objects delegating functions to other objects. To
keep track of which object is handling what function, TOOL provides
two methods *graft* and *organ*.

<pre><code>tool::class create human {}

human create bob name Robert
car1 graft driver bob
bob graft car car1
bob &lt;car&gt; physics speed
> 10
car1 &lt;driver&gt; cget name
> Robert
car1 organ driver
> bob
bob organ car
> car1
</code></pre>

## Method Ensembles

TOOL also introduces the concept of a method ensemble. To declare an ensemble
use a :: delimter in the name of the method.

<pre><code>tool::class create special {

  method foo::bar {} {
    return bar
  }
  method foo::baz {} {
    return baz
  }
  method foo::bat {} {
    return bat
  }
}

special create blah
bah foo <list>
> bar bat baz
bah foo bar
> bar
bar foo bing
> ERROR: Invalid command "bing", Valid: bar, bat, baz
</code></pre>

Keep in mind that everything is changeable on demand in TOOL,
and if you define a *default* method that will override the standard
unknown reply:

<pre><code>tool::define special {
  method foo::default args {
    return [list $method $args]  
  }
}
bar foo bing
> bing
</code></pre>

Added modules/tool/tool.tcl.



















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
###
# Amalgamated package for tool
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package provide tool 0.7
namespace eval ::tool {}

###
# START: core.tcl
###
package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
package require dicttool
package require TclOO
package require sha1
#package require cron 2.0
package require oo::meta 0.5.1
package require oo::dialect

::oo::dialect::create ::tool
::namespace eval ::tool {}
set ::tool::trace 0

proc ::tool::script_path {} {
  set path [file dirname [file join [pwd] [info script]]]
  return $path
}

proc ::tool::module {cmd args} {
  ::variable moduleStack
  ::variable module

  switch $cmd {
    push {
      set module [lindex $args 0]
      lappend moduleStack $module
      return $module
    }
    pop {
      set priormodule      [lindex $moduleStack end]
      set moduleStack [lrange $moduleStack 0 end-1]
      set module [lindex $moduleStack end]
      return $priormodule
    }
    peek {
      set module      [lindex $moduleStack end]
      return $module
    }
    default {
      error "Invalid command \"$cmd\". Valid: peek, pop, push"
    }
  }
}
::tool::module push core

proc ::tool::pathload {path {order {}} {skip {}}} {
  ###
  # On windows while running under a VFS, the system sometimes
  # gets confused about the volume we are running under
  ###
  if {$::tcl_platform(platform) eq "windows"} {
    if {[string range $path 1 6] eq ":/zvfs"} {
      set path [string range $path 2 end]
    }
  }
  set loaded {pkgIndex.tcl index.tcl}
  foreach item $skip {
    lappend loaded [file tail $skip]
  }
  if {[file exists [file join $path metaclass.tcl]]} {
    lappend loaded metaclass.tcl
    uplevel #0 [list source [file join $path metaclass.tcl]]
  }
  if {[file exists [file join $path baseclass.tcl]]} {
    lappend loaded baseclass.tcl
    uplevel #0 [list source [file join $path baseclass.tcl]]
  }
  foreach file $order {
    set file [file tail $file]
    if {$file in $loaded} continue
    if {![file exists [file join $path $file]]} {
      puts "WARNING [file join $path $file] does not exist in [info script]"
    } else {
      uplevel #0 [list source [file join $path $file]]
    }
    lappend loaded $file
  }
  foreach file [lsort -dictionary [glob -nocomplain [file join $path *.tcl]]] {
    if {[file tail $file] in $loaded} continue
    uplevel #0 [list source $file]
    lappend loaded [file tail $file]
  }
}

###
# END: core.tcl
###
###
# START: uuid.tcl
###
::namespace eval ::tool {}

proc ::tool::is_null value {
  return [expr {$value in {{} NULL}}]
}


proc ::tool::uuid_seed args {
  if {[llength $args]==0 || ([llength $args]==1 && [is_null [lindex $args 0]])} {
    if {[info exists ::env(USERNAME)]} {
      set user $::env(USERNAME)
    } elseif {[info exists ::env(USER)]} {
      set user $::env(USER)
    } else {
      set user $::env(user)
    }
    incr ::tool::nextuuid $::tool::globaluuid
    set ::tool::UUID_Seed [list user@[info hostname] [clock format [clock seconds]]]
  } else {
    incr ::tool::globaluuid $::tool::nextuuid
    set ::tool::nextuuid 0
    set ::tool::UUID_Seed $args
  }
}

###
# topic: 0a19b0bfb98162a8a37c1d3bbfb8bc3d
# description:
#    Because the tcllib version of uuid generate requires
#    network port access (which can be slow), here's a fast
#    and dirty rendition
###
proc ::tool::uuid_generate args {
  if {![llength $args]} {
    set block [list [incr ::tool::nextuuid] {*}$::tool::UUID_Seed]
  } else {
    set block $args
  }
  return [::sha1::sha1 -hex [join $block ""]]
}

###
# topic: ee3ec43cc2cc2c7d6cf9a4ef1c345c19
###
proc ::tool::uuid_short args {
  if {![llength $args]} {
    set block [list [incr ::tool::nextuuid] {*}$::tool::UUID_Seed]
  } else {
    set block $args
  }
  return [string range [::sha1::sha1 -hex [join $block ""]] 0 16]
}

###
# topic: b14c505537274904578340ec1bc12af1
# description:
#    Implementation the uses a compiled in ::md5 implementation
#    commonly used by embedded application developers
###
namespace eval ::tool {
  namespace export *
}
###
# Cache the bits of the UUID seed that aren't likely to change
# once the software is loaded, but which can be expensive to
# generate
###
set ::tool::nextuuid 0
set ::tool::globaluuid 0
::tool::uuid_seed

###
# END: uuid.tcl
###
###
# START: ensemble.tcl
###
::namespace eval ::tool::define {}

if {![info exists ::tool::dirty_classes]} {
  set ::tool::dirty_classes {}
}

###
# Monkey patch oometa's rebuild function to
# include a notifier to tool
###
proc ::oo::meta::rebuild args {
  foreach class $args {
    if {$class ni $::oo::meta::dirty_classes} {
      lappend ::oo::meta::dirty_classes $class
    }
    if {$class ni $::tool::dirty_classes} {
      lappend ::tool::dirty_classes $class
    }
  }
}

proc ::tool::ensemble_build_map args {
  set emap {}
  foreach thisclass $args {
    foreach {ensemble einfo} [::oo::meta::info $thisclass getnull method_ensemble] {
      foreach {submethod subinfo} $einfo {
        dict set emap $ensemble $submethod $subinfo
      }
    }
  }
  return $emap
}

proc ::tool::ensemble_methods emap {
  set result {}
  foreach {ensemble einfo} $emap {
    #set einfo [dict getnull $einfo method_ensemble $ensemble]
    set eswitch {}
    set default standard
    if {[dict exists $einfo default:]} {
      set emethodinfo [dict get $einfo default:]
      set arglist     [lindex $emethodinfo 0]
      set realbody    [lindex $emethodinfo 1]
      if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} {
        set body {}
      } else {
        set body "\n      ::tool::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
      }
      append body "\n      " [string trim $realbody] "      \n"
      set default $body
      dict unset einfo default:
    }
    set methodlist {}
    foreach item [dict keys $einfo] {
      lappend methodlist [string trimright $item :]
    }
    set methodlist  [lsort -dictionary -unique $methodlist]
    foreach {submethod esubmethodinfo} [lsort -dictionary -stride 2 $einfo] {
      if {$submethod in {"_preamble:" "default:"}} continue
      set submethod [string trimright $submethod :]
      lassign $esubmethodinfo arglist realbody
      if {[string length [string trim $realbody]] eq {}} {
        dict set eswitch $submethod {}
      } else {
        if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} {
          set body {}
        } else {
          set body "\n      ::tool::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
        }
        append body "\n      " [string trim $realbody] "      \n"
        dict set eswitch $submethod $body
      }
    }
    if {![dict exists $eswitch <list>]} {
      dict set eswitch <list> {return $methodlist}
    }
    if {$default=="standard"} {
      set default "error \"unknown method $ensemble \$method. Valid: \$methodlist\""
    }
    dict set eswitch default $default
    set mbody {}    
    if {[dict exists $einfo _preamble:]} {
      append mbody [lindex [dict get $einfo _preamble:] 1] \n
    }
    append mbody \n [list set methodlist $methodlist]
    append mbody \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]"
    append mbody \n {return -options $opts $result}
    append result \n [list method $ensemble {{method default} args} $mbody]    
  }
  return $result
}

###
# topic: fb8d74e9c08db81ee6f1275dad4d7d6f
###
proc ::tool::dynamic_object_ensembles {thisobject thisclass} {
  variable trace
  set ensembledict {}
  foreach dclass $::tool::dirty_classes {
    foreach {cclass cancestors} [array get ::oo::meta::cached_hierarchy] {
      if {$dclass in $cancestors} {
        unset -nocomplain ::tool::obj_ensemble_cache($cclass)
      }
    }
  }
  set ::tool::dirty_classes {}
  ###
  # Only go through the motions for classes that have a locally defined
  # ensemble method implementation
  ###
  foreach aclass [::oo::meta::ancestors $thisclass] {
    if {[info exists ::tool::obj_ensemble_cache($aclass)]} continue
    set emap [::tool::ensemble_build_map $aclass]
    set body [::tool::ensemble_methods $emap]
    oo::define $aclass $body
    # Define a property for this ensemble for introspection
    foreach {ensemble einfo} $emap {
      ::oo::meta::info $aclass set ensemble_methods $ensemble: [lsort -dictionary [dict keys $einfo]]
    }
    set ::tool::obj_ensemble_cache($aclass) 1
  }
}

###
# topic: ec9ca249b75e2667ad5bcb2f7cd8c568
# title: Define an ensemble method for this agent
###
::proc ::tool::define::method {rawmethod args} {
  set class [current_class]
  set mlist [split $rawmethod "::"]
  if {[llength $mlist]==1} {
    ###
    # Simple method, needs no parsing
    ###
    set method $rawmethod
    ::oo::define $class method $rawmethod {*}$args
    return
  }
  set ensemble [lindex $mlist 0]
  set method [join [lrange $mlist 2 end] "::"]
  switch [llength $args] {
    1 {
      ::oo::meta::info $class set method_ensemble $ensemble $method: [list dictargs [lindex $args 0]]
    }
    2 {
      ::oo::meta::info $class set method_ensemble $ensemble $method: $args
    }
    default {
      error "Usage: method NAME ARGLIST BODY"
    }
  }
}

###
# topic: 354490e9e9708425a6662239f2058401946e41a1
# description: Creates a method which exports access to an internal dict
###
proc ::tool::define::dictobj args {
  dict_ensemble {*}$args
}
proc ::tool::define::dict_ensemble {methodname varname {cases {}}} {
  set class [current_class]
  set CASES [string map [list %METHOD% $methodname %VARNAME% $varname] $cases]
  
  set methoddata [::oo::meta::info $class getnull method_ensemble $methodname]
  set initial [dict getnull $cases initialize]
  variable $varname $initial
  foreach {name body} $CASES {
    dict set methoddata $name: [list args $body]
  }
  set template [string map [list %CLASS% $class %INITIAL% $initial %METHOD% $methodname %VARNAME% $varname] {
    _preamble {} {
      my variable %VARNAME%
    }
    add args {
      set field [string trimright [lindex $args 0] :]
      set data [dict getnull $%VARNAME% $field]
      foreach item [lrange $args 1 end] {
        if {$item ni $data} {
          lappend data $item
        }
      }
      dict set %VARNAME% $field $data
    }
    remove args {
      set field [string trimright [lindex $args 0] :]
      set data [dict getnull $%VARNAME% $field]
      set result {}
      foreach item $data {
        if {$item in $args} continue
        lappend result $item
      }
      dict set %VARNAME% $field $result
    }
    initial {} {
      return [dict rmerge [my meta branchget %VARNAME%] {%INITIAL%}]
    }
    reset {} {
      set %VARNAME% [dict rmerge [my meta branchget %VARNAME%] {%INITIAL%}]
      return $%VARNAME%
    }
    dump {} {
      return $%VARNAME%
    }
    append args {
      return [dict $method %VARNAME% {*}$args]
    }
    incr args {
      return [dict $method %VARNAME% {*}$args]
    }
    lappend args {
      return [dict $method %VARNAME% {*}$args]
    }
    set args {
      return [dict $method %VARNAME% {*}$args]
    }
    unset args {
      return [dict $method %VARNAME% {*}$args]
    }
    update args {
      return [dict $method %VARNAME% {*}$args]
    }
    branchset args {
      foreach {field value} [lindex $args end] {
        dict set %VARNAME% {*}[lrange $args 0 end-1] [string trimright $field :]: $value
      }
    }
    rmerge args {
      set %VARNAME% [dict rmerge $%VARNAME% {*}$args]
      return $%VARNAME%  
    }
    merge args {
      set %VARNAME% [dict rmerge $%VARNAME% {*}$args]
      return $%VARNAME%
    }
    replace args {
      set %VARNAME% [dict rmerge $%VARNAME% {%INITIAL%} {*}$args]
    }
    default args {
      return [dict $method $%VARNAME% {*}$args]
    }
  }]
  foreach {name arglist body} $template {
    if {[dict exists $methoddata $name:]} continue
    dict set methoddata $name: [list $arglist $body]
  }
  ::oo::meta::info $class set method_ensemble $methodname $methoddata
}

proc ::tool::define::arrayobj args {
  array_ensemble {*}$args
}

###
# topic: 354490e9e9708425a6662239f2058401946e41a1
# description: Creates a method which exports access to an internal array
###
proc ::tool::define::array_ensemble {methodname varname {cases {}}} {
  set class [current_class]
  set CASES [string map [list %METHOD% $methodname %VARNAME% $varname] $cases]
  set initial [dict getnull $cases initialize]
  array $varname $initial

  set map [list %CLASS% $class %METHOD% $methodname %VARNAME% $varname %CASES% $CASES %INITIAL% $initial]

  ::oo::define $class method _${methodname}Get {field} [string map $map {
    my variable %VARNAME%
    if {[info exists %VARNAME%($field)]} {
      return $%VARNAME%($field)
    }
    return [my meta getnull %VARNAME% $field:]
  }]
  ::oo::define $class method _${methodname}Exists {field} [string map $map {
    my variable %VARNAME%
    if {[info exists %VARNAME%($field)]} {
      return 1
    }
    return [my meta exists %VARNAME% $field:]
  }]
  set methoddata [::oo::meta::info $class set array_ensemble $methodname: $varname]
  
  set methoddata [::oo::meta::info $class getnull method_ensemble $methodname]
  foreach {name body} $CASES {
    dict set methoddata $name: [list args $body]
  } 
  set template  [string map [list %CLASS% $class %INITIAL% $initial %METHOD% $methodname %VARNAME% $varname] {
    _preamble {} {
      my variable %VARNAME%
    }
    reset {} {
      ::array unset %VARNAME% *
      foreach {field value} [my meta getnull %VARNAME%] {
        set %VARNAME%([string trimright $field :]) $value
      }
      ::array set %VARNAME% {%INITIAL%}
      return [array get %VARNAME%]
    }
    ni value {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      return [expr {$value ni $data}]
    }
    in value {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      return [expr {$value in $data}]
    }
    add args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      foreach item [lrange $args 1 end] {
        if {$item ni $data} {
          lappend data $item
        }
      }
      set %VARNAME%($field) $data
    }
    remove args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      set result {}
      foreach item $data {
        if {$item in $args} continue
        lappend result $item
      }
      set %VARNAME%($field) $result
    }
    dump {} {
      set result {}
      foreach {var val} [my meta getnull %VARNAME%] {
        dict set result [string trimright $var :] $val
      }
      foreach {var val} [lsort -dictionary -stride 2 [array get %VARNAME%]] {
        dict set result [string trimright $var :] $val
      }
      return $result
    }
    exists args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Exists $field]
    }
    getnull args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]      
    }
    get field {
      set field [string trimright $field :]
      set data [my _%METHOD%Get $field]
    }
    set args {
      set field [string trimright [lindex $args 0] :]
      ::set %VARNAME%($field) {*}[lrange $args 1 end]        
    }
    append args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      ::append data {*}[lrange $args 1 end]
      set %VARNAME%($field) $data
    }
    incr args {
      set field [string trimright [lindex $args 0] :]
      ::incr %VARNAME%($field) {*}[lrange $args 1 end]
    }
    lappend args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      $method data {*}[lrange $args 1 end]
      set %VARNAME%($field) $data
    }
    branchset args {
      foreach {field value} [lindex $args end] {
        set %VARNAME%([string trimright $field :]) $value
      }
    }
    rmerge args {
      foreach arg $args {
        my %VARNAME% branchset $arg
      }
    }
    merge args {
      foreach arg $args {
        my %VARNAME% branchset $arg
      }
    }
    default args {
      return [array $method %VARNAME% {*}$args]
    }
  }]
  foreach {name arglist body} $template {
    if {[dict exists $methoddata $name:]} continue
    dict set methoddata $name: [list $arglist $body]
  }
  ::oo::meta::info $class set method_ensemble $methodname $methoddata
}


###
# END: ensemble.tcl
###
###
# START: metaclass.tcl
###
#-------------------------------------------------------------------------
# TITLE: 
#    tool.tcl
#
# PROJECT:
#    tool: TclOO Helper Library
#
# DESCRIPTION:
#    tool(n): Implementation File
#
#-------------------------------------------------------------------------

namespace eval ::tool {}

###
# New OO Keywords for TOOL
###
namespace eval ::tool::define {}
proc ::tool::define::array {name {values {}}} {
  set class [current_class]
  set name [string trimright $name :]:
  if {![::oo::meta::info $class exists array $name]} {
    ::oo::meta::info $class set array $name {}
  }
  foreach {var val} $values {
    ::oo::meta::info $class set array $name: $var $val
  }
}

###
# topic: 710a93168e4ba7a971d3dbb8a3e7bcbc
###
proc ::tool::define::component {name info} {
  set class [current_class]
  ::oo::meta::info $class branchset component $name $info
}

###
# topic: 2cfc44a49f067124fda228458f77f177
# title: Specify the constructor for a class
###
proc ::tool::define::constructor {arglist rawbody} {
  set body {
::tool::object_create [self] [info object class [self]]
# Initialize public variables and options
my InitializePublic
  }
  append body $rawbody
  append body {
# Run "initialize"
my initialize
  }
  set class [current_class]
  ::oo::define $class constructor $arglist $body
}

###
# topic: 7a5c7e04989704eef117ff3c9dd88823
# title: Specify the a method for the class object itself, instead of for objects of the class
###
proc ::tool::define::class_method {name arglist body} {
  set class [current_class]
  ::oo::meta::info $class set class_typemethod $name: [list $arglist $body]
}

###
# topic: 4cb3696bf06d1e372107795de7fe1545
# title: Specify the destructor for a class
###
proc ::tool::define::destructor rawbody {
  set body {
# Run the destructor once and only once
set self [self]
my variable DestroyEvent
if {$DestroyEvent} return
set DestroyEvent 1
::tool::object_destroy $self
}
  append body $rawbody
  ::oo::define [current_class] destructor $body
}

###
# topic: 8bcae430f1eda4ccdb96daedeeea3bd409c6bb7a
# description: Add properties and option handling
###
proc ::tool::define::property args {
  set class [current_class]
  switch [llength $args] {
    2 {
      set type const
      set property [string trimleft [lindex $args 0] :]
      set value [lindex $args 1]
      ::oo::meta::info $class set $type $property: $value
      return
    }
    3 {
      set type     [lindex $args 0]
      set property [string trimleft [lindex $args 1] :]
      set value    [lindex $args 2]
      ::oo::meta::info $class set $type $property: $value
      return
    }
    default {
      error "Usage:
property name type valuedict
OR property name value"
    }
  }
  ::oo::meta::info $class set {*}$args
}

###
# topic: 615b7c43b863b0d8d1f9107a8d126b21
# title: Specify a variable which should be initialized in the constructor
# description:
#    This keyword can also be expressed:
#    [example {property variable NAME {default DEFAULT}}]
#    [para]
#    Variables registered in the variable property are also initialized
#    (if missing) when the object changes class via the [emph morph] method.
###
proc ::tool::define::variable {name {default {}}} {
  set class [current_class]
  set name [string trimright $name :]
  ::oo::meta::info $class set variable $name: $default
  ::oo::define $class variable $name
}

###
# Utility Procedures
###

# topic: 643efabec4303b20b66b760a1ad279bf
###
proc ::tool::args_to_dict args {
  if {[llength $args]==1} {
    return [lindex $args 0]
  }
  return $args
}

###
# topic: b40970b0d9a2525990b9105ec8c96d3d
###
proc ::tool::args_to_options args {
  set result {}
  foreach {var val} [args_to_dict {*}$args] {
    lappend result [string trimright [string trimleft $var -] :] $val
  }
  return $result
}

###
# topic: a92cd258900010f656f4c6e7dbffae57
###
proc ::tool::dynamic_methods class {
  ::oo::meta::rebuild $class
  set metadata [::oo::meta::metadata $class]
  foreach command [info commands [namespace current]::dynamic_methods_*] {
    $command $class $metadata
  }
}

###
# topic: 4969d897a83d91a230a17f166dbcaede
###
proc ::tool::dynamic_arguments {ensemble method arglist args} {
  set idx 0
  set len [llength $args]
  if {$len > [llength $arglist]} {
    ###
    # Catch if the user supplies too many arguments
    ###
    set dargs 0
    if {[lindex $arglist end] ni {args dictargs}} {
      return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
    }
  }
  foreach argdef $arglist {
    if {$argdef eq "args"} {
      ###
      # Perform args processing in the style of tcl
      ###
      uplevel 1 [list set args [lrange $args $idx end]]
      break
    }
    if {$argdef eq "dictargs"} {
      ###
      # Perform args processing in the style of tcl
      ###
      uplevel 1 [list set args [lrange $args $idx end]]
      ###
      # Perform args processing in the style of tool
      ###
      set dictargs [::tool::args_to_options {*}[lrange $args $idx end]]
      uplevel 1 [list set dictargs $dictargs]
      break
    }
    if {$idx > $len} {
      ###
      # Catch if the user supplies too few arguments
      ###
      if {[llength $argdef]==1} {
        return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
      } else {
        uplevel 1 [list set [lindex $argdef 0] [lindex $argdef 1]]
      }
    } else {
      uplevel 1 [list set [lindex $argdef 0] [lindex $args $idx]]
    }
    incr idx
  }
}

###
# topic: b88add196bb63abccc44639db5e5eae1
###
proc ::tool::dynamic_methods_class {thisclass metadata} {
  foreach {method info} [dict getnull $metadata class_typemethod] {
    lassign $info arglist body
    set method [string trimright $method :]
    ::oo::objdefine $thisclass method $method $arglist $body
  }
}

###
# topic: 53ab28ac5c6ee601fe1fe07b073be88e
###
proc ::tool::dynamic_wrongargs_message {arglist} {
  set result ""
  set dargs 0
  foreach argdef $arglist {
    if {$argdef in {args dictargs}} {
      set dargs 1
      break
    }
    if {[llength $argdef]==1} {
      append result " $argdef"
    } else {
      append result " ?[lindex $argdef 0]?"
    }
  }
  if { $dargs } {
    append result " ?option value?..."
  }
  return $result
}

proc ::tool::object_create {objname {class {}}} {
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    set ${varname}($objname) {}
  }
  if {$class eq {}} {
    set class [info object class $objname]
  }
   set object_info($objname) [list class $class]
  if {$class ne {}} {
    $objname graft class $class
    foreach command [info commands [namespace current]::dynamic_object_*] {
      $command $objname $class
    }
  }
}


proc ::tool::object_rename {object newname} {
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    if {[info exists ${varname}($object)]} {
      set ${varname}($newname) [set ${varname}($object)]
      unset ${varname}($object)
    }
  }
  variable coroutine_object
  foreach {coro coro_objname} [array get coroutine_object] {
    if { $object eq $coro_objname } {
      set coroutine_object($coro) $newname
    }
  }
  rename $object ::[string trimleft $newname]
  ::tool::event::generate $object object_rename [list newname $newname]
}

proc ::tool::object_destroy objname {
  ::tool::event::generate $objname object_destroy [list objname $objname]
  ::tool::event::cancel $objname *
  ::cron::object_destroy $objname
  variable coroutine_object
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    unset -nocomplain ${varname}($objname)
  }
}

#-------------------------------------------------------------------------
# Option Handling Mother of all Classes

# tool::object
#
# This class is inherited by all classes that have options.
#

::tool::define ::tool::object {
  # Put MOACish stuff in here
  variable signals_pending create
  variable organs {}
  variable mixins {}
  variable mixinmap {}
  variable DestroyEvent 0

  constructor args {
    my Config_merge [::tool::args_to_options {*}$args]
  }
  
  destructor {}
    
  method ancestors {{reverse 0}} {
    set result [::oo::meta::ancestors [info object class [self]]]
    if {$reverse} {
      return [lreverse $result]
    }
    return $result
  }
  
  method DestroyEvent {} {
    my variable DestroyEvent
    return $DestroyEvent
  }
  
  ###
  # title: Forward a method
  ###
  method forward {method args} {
    oo::objdefine [self] forward $method {*}$args
  }
  
  ###
  # title: Direct a series of sub-functions to a seperate object
  ###
  method graft args {
    my variable organs
    if {[llength $args] == 1} {
      error "Need two arguments"
    }
    set object {}
    foreach {stub object} $args {
      if {$stub eq "class"} {
        # Force class to always track the object's current class
        set obj [info object class [self]]
      }
      dict set organs $stub $object
      oo::objdefine [self] forward <${stub}> $object
      oo::objdefine [self] export <${stub}>
    }
    return $object
  }
  
  # Called after all options and public variables are initialized
  method initialize {} {}
  
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  method InitializePublic {} {
    my variable config meta
    if {![info exists meta]} {
      set meta {}
    }
    if {![info exists config]} {
      set config {}
    }
    my ClassPublicApply {}
  }
  
  class_method info {which} {
    my variable cache
    if {![info exists cache($which)]} {
      set cache($which) {}
      switch $which {
        public {
          dict set cache(public) variable [my meta branchget variable]
          dict set cache(public) array [my meta branchget array]
          set optinfo [my meta getnull option]
          dict set cache(public) option_info $optinfo
          foreach {var info} [dict getnull $cache(public) option_info] {
            if {[dict exists $info aliases:]} {
              foreach alias [dict exists $info aliases:] {
                dict set cache(public) option_canonical $alias $var
              }
            }
            set getcmd [dict getnull $info default-command:]
            if {$getcmd ne {}} {
              dict set cache(public) option_default_command $var $getcmd
            } else {
              dict set cache(public) option_default_value $var [dict getnull $info default:]
            }
            dict set cache(public) option_canonical $var $var
          }
        }
      }
    }
    return $cache($which)
  }
  
  ###
  # Incorporate the class's variables, arrays, and options
  ###
  method ClassPublicApply class {
    my variable config
    set integrate 0
    if {$class eq {}} {
      set class [info object class [self]]      
    } else {
      set integrate 1
    }
    set public [$class info public]
    foreach {var value} [dict getnull $public variable] {
      if { $var in {meta config} } continue
      my variable $var
      if {![info exists $var]} {
        set $var $value
      }
    }
    foreach {var value} [dict getnull $public array] {
      if { $var eq {meta config} } continue
      my variable $var
      foreach {f v} $value {
        if {![array exists ${var}($f)]} {
          set ${var}($f) $v
        }
      }
    }
    set dat [dict getnull $public option_info]
    if {$integrate} {
      my meta rmerge [list option $dat]
    }
    my variable option_canonical
    array set option_canonical [dict getnull $public option_canonical]
    set dictargs {}
    foreach {var getcmd} [dict getnull $public option_default_command] {
      if {[dict getnull $dat $var class:] eq "organ"} {
        if {[my organ $var] ne {}} continue
      }
      if {[dict exists $config $var]} continue
      dict set dictargs $var [{*}[string map [list %field% $var %self% [namespace which my]] $getcmd]]
    }
    foreach {var value} [dict getnull $public option_default_value] {
      if {[dict getnull $dat $var class:] eq "organ"} {
        if {[my organ $var] ne {}} continue
      }
      if {[dict exists $config $var]} continue
      dict set dictargs $var $value
    }
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {
      if {[dict exists $config $field]} continue
      set script [dict getnull $dat $field set-command:]
      dict set config $field $val
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
  }
  
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  method mixin args {
    ###
    # Mix in the class
    ###
    my variable mixins
    set prior $mixins

    set mixins $args
    ::oo::objdefine [self] mixin {*}$args
    ###
    # Build a compsite map of all ensembles defined by the object's current
    # class as well as all of the classes being mixed in
    ###
    set emap [::tool::ensemble_build_map [::info object class [self]] {*}[lreverse $args]]
    set body [::tool::ensemble_methods $emap]
    oo::objdefine [self] $body
    foreach class $args {
      if {$class ni $prior} {
        my meta mixin $class
      }
      my ClassPublicApply $class
    }
    foreach class $prior {
      if {$class ni $mixins } { 
        my meta mixout $class
      }
    }
  }

  method mixinmap args { 
    my variable mixinmap
    set priorlist {}
    foreach {slot classes} $args {
      if {[dict exists $mixinmap $slot]} {
        lappend priorlist {*}[dict get $mixinmap $slot]  
        foreach class [dict get $mixinmap $slot] {
          if {$class ni $classes && [$class meta exists mixin unmap-script:]} {
            if {[catch [$class meta get mixin unmap-script:] err errdat]} {
              puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]"
            }
          }
        }
      }
      dict set mixinmap $slot $classes
    }
    my Recompute_Mixins
    foreach {slot classes} $args {
      foreach class $classes {
        if {$class ni $priorlist && [$class meta exists mixin map-script:]} {
          if {[catch [$class meta get mixin map-script:] err errdat]} {
            puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]"
          }
        }
      }
    }
    foreach {slot classes} $mixinmap {
      foreach class $classes {
        if {[$class meta exists mixin react-script:]} {
          if {[catch [$class meta get mixin react-script:] err errdat]} {
            puts stderr "[self] MIXIN ERROR REACTING $class:\n[dict get $errdat -errorinfo]"
          }
        }
      }
    }
  }

  method debug_mixinmap {} {
    my variable mixinmap
    return $mixinmap
  }

  method Recompute_Mixins {} {
    my variable mixinmap
    set classlist {}
    foreach {item class} $mixinmap {
      if {$class ne {}} {
        lappend classlist $class
      }
    }
    my mixin {*}$classlist
  }
  
  method morph newclass {
    if {$newclass eq {}} return
    set class [string trimleft [info object class [self]]]
    set newclass [string trimleft $newclass :]
    if {[info command ::$newclass] eq {}} {
      error "Class $newclass does not exist"
    }
    if { $class ne $newclass } {
      my Morph_leave
      my variable mixins
      oo::objdefine [self] class ::${newclass}
      my graft class ::${newclass}
      # Reapply mixins
      my mixin {*}$mixins
      my InitializePublic
      my Morph_enter
    }
  }

  ###
  # Commands to perform as this object transitions out of the present class
  ###
  method Morph_leave {} {}
  ###
  # Commands to perform as this object transitions into this class as a new class
  ###
  method Morph_enter {} {}
  
  ###
  # title: List which objects are forwarded as organs
  ###
  method organ {{stub all}} {
    my variable organs
    if {![info exists organs]} {
      return {}
    }
    if { $stub eq "all" } {
      return $organs
    }
    return [dict getnull $organs $stub]
  }
}



###
# END: metaclass.tcl
###
###
# START: option.tcl
###
###
# topic: 68aa446005235a0632a10e2a441c0777
# title: Define an option for the class
###
proc ::tool::define::option {name args} {
  set class [current_class]
  set dictargs {default: {}}
  foreach {var val} [::oo::meta::args_to_dict {*}$args] {
    dict set dictargs [string trimright [string trimleft $var -] :]: $val
  }
  set name [string trimleft $name -]

  ###
  # Option Class handling
  ###
  set optclass [dict getnull $dictargs class:]
  if {$optclass ne {}} {
    foreach {f v} [::oo::meta::info $class getnull option_class $optclass] {
      if {![dict exists $dictargs $f]} {
        dict set dictargs $f $v
      }
    }
    if {$optclass eq "variable"} {
      variable $name [dict getnull $dictargs default:]
    }
  }
  ::oo::meta::info $class branchset option $name $dictargs
}

###
# topic: 827a3a331a2e212a6e301f59c1eead59
# title: Define a class of options
# description:
#    Option classes are a template of properties that other
#    options can inherit.
###
proc ::tool::define::option_class {name args} {
  set class [current_class]
  set dictargs {default {}}
  foreach {var val} [::oo::meta::args_to_dict {*}$args] {
    dict set dictargs [string trimleft $var -] $val
  }
  set name [string trimleft $name -]
  ::oo::meta::info $class branchset option_class $name $dictargs
}

::tool::define ::tool::object {
  property options_strict 0
  variable organs {}

  option_class organ {
    widget label
    set-command {my graft %field% %value%}
    get-command {my organ %field%}
  }

  option_class variable {
    widget entry
    set-command {my variable %field% ; set %field% %value%}
    get-command {my variable %field% ; set %field%}
  }
  
  dict_ensemble config config {
    get {
      return [my Config_get {*}$args]
    }
    merge {
      return [my Config_merge {*}$args]
    }
    set {
      my Config_set {*}$args
    }
  }

  ###
  # topic: 86a1b968cea8d439df87585afdbdaadb
  ###
  method cget args {
    return [my Config_get {*}$args]
  }

  ###
  # topic: 73e2566466b836cc4535f1a437c391b0
  ###
  method configure args {
    # Will be removed at the end of "configurelist_triggers"
    set dictargs [::oo::meta::args_to_options {*}$args]
    if {[llength $dictargs] == 1} {
      return [my cget [lindex $dictargs 0]]
    }
    set dat [my Config_merge $dictargs]
    my Config_triggers $dat
  }

  method Config_get {field args} {
    my variable config option_canonical option_getcmd
    set field [string trimleft $field -]
    if {[info exists option_canonical($field)]} {
      set field $option_canonical($field)
    }
    if {[info exists option_getcmd($field)]} {
      return [eval $option_getcmd($field)]
    }
    if {[dict exists $config $field]} {
      return [dict get $config $field]
    }
    if {[llength $args]} {
      return [lindex $args 0]
    }
    return [my meta cget $field] 
  }
  
  ###
  # topic: dc9fba12ec23a3ad000c66aea17135a5
  ###
  method Config_merge dictargs {
    my variable config option_canonical
    set rawlist $dictargs
    set dictargs {}
    set dat [my meta getnull option]
    foreach {field val} $rawlist {
      set field [string trimleft $field -]
      set field [string trimright $field :]
      if {[info exists option_canonical($field)]} {
        set field $option_canonical($field)
      }
      dict set dictargs $field $val
    }
    ###
    # Validate all inputs
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field validate-command:]
      if {$script ne {}} {
        dict set dictargs $field [eval [string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]]
      }
    }
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field set-command:]
      dict set config $field $val
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
    return $dictargs
  }
  
  method Config_set args {
    set dictargs [::tool::args_to_options {*}$args]
    set dat [my Config_merge $dictargs]
    my Config_triggers $dat
  }
  
  ###
  # topic: 543c936485189593f0b9ed79b5d5f2c0
  ###
  method Config_triggers dictargs {
    set dat [my meta getnull option]
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field post-command:]
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
  }

  method Option_Default field {
    set info [my meta getnull option $field]
    set getcmd [dict getnull $info default-command:]
    if {$getcmd ne {}} {
      return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
    } else {
      return [dict getnull $info default:]
    }
  }
}

package provide tool::option 0.1

###
# END: option.tcl
###
###
# START: event.tcl
###
###
# This file implements the Tool event manager
###

::namespace eval ::tool {}

::namespace eval ::tool::event {}

###
# topic: f2853d380a732845610e40375bcdbe0f
# description: Cancel a scheduled event
###
proc ::tool::event::cancel {self {task *}} {
  variable timer_event
  variable timer_script

  foreach {id event} [array get timer_event $self:$task] {
    ::after cancel $event
    set timer_event($id) {}
    set timer_script($id) {}
  }
}

###
# topic: 8ec32f6b6ba78eaf980524f8dec55b49
# description:
#    Generate an event
#    Adds a subscription mechanism for objects
#    to see who has recieved this event and prevent
#    spamming or infinite recursion
###
proc ::tool::event::generate {self event args} {
  set wholist [Notification_list $self $event]
  if {$wholist eq {}} return
  set dictargs [::oo::meta::args_to_options {*}$args]
  set info $dictargs
  set strict 0
  set debug 0
  set sender $self
  dict with dictargs {}
  dict set info id     [::tool::event::nextid]
  dict set info origin $self
  dict set info sender $sender
  dict set info rcpt   {}
  foreach who $wholist {
    catch {::tool::event::notify $who $self $event $info}
  }
}

###
# topic: 891289a24b8cc52b6c228f6edb169959
# title: Return a unique event handle
###
proc ::tool::event::nextid {} {
  return "event#[format %0.8x [incr ::tool::event_count]]"
}

###
# topic: 1e53e8405b4631aec17f98b3e8a5d6a4
# description:
#    Called recursively to produce a list of
#    who recieves notifications
###
proc ::tool::event::Notification_list {self event {stackvar {}}} {
  set notify_list {}
  foreach {obj patternlist} [array get ::tool::object_subscribe] {
    if {$obj eq $self} continue
    if {$obj in $notify_list} continue
    set match 0
    foreach {objpat eventlist} $patternlist {
      if {![string match $objpat $self]} continue
      foreach eventpat $eventlist {
        if {![string match $eventpat $event]} continue
        set match 1
        break
      }
      if {$match} {
        break
      }
    }
    if {$match} {
      lappend notify_list $obj
    }
  }
  return $notify_list
}

###
# topic: b4b12f6aed69f74529be10966afd81da
###
proc ::tool::event::notify {rcpt sender event eventinfo} {
  if {[info commands $rcpt] eq {}} return 
  if {$::tool::trace} {
    puts [list event notify rcpt $rcpt sender $sender event $event info $eventinfo]
  }
  $rcpt notify $event $sender $eventinfo
}

###
# topic: 829c89bda736aed1c16bb0c570037088
###
proc ::tool::event::process {self handle script} {
  variable timer_event
  variable timer_script

  array unset timer_event $self:$handle
  array unset timer_script $self:$handle

  set err [catch {uplevel #0 $script} result errdat]
  if $err {
    puts "BGError: $self $handle $script
ERR: $result
[dict get $errdat -errorinfo]
***"
  }
}

###
# topic: eba686cffe18cd141ac9b4accfc634bb
# description: Schedule an event to occur later
###
proc ::tool::event::schedule {self handle interval script} {
  variable timer_event
  variable timer_script
  if {$::tool::trace} {
    puts [list $self schedule $handle $interval]
  }
  if {[info exists timer_event($self:$handle)]} {
    if {$script eq $timer_script($self:$handle)} {
      return
    }
    ::after cancel $timer_event($self:$handle)
  }
  set timer_script($self:$handle) $script
  set timer_event($self:$handle) [::after $interval [list ::tool::event::process $self $handle $script]]
}

proc ::tool::event::sleep msec {
  ::cron::sleep $msec
}

###
# topic: e64cff024027ee93403edddd5dd9fdde
###
proc ::tool::event::subscribe {self who event} {
  upvar #0 ::tool::object_subscribe($self) subscriptions
  if {![info exists subscriptions]} {
    set subscriptions {}
  }
  set match 0
  foreach {objpat eventlist} $subscriptions {
    if {![string match $objpat $who]} continue      
    foreach eventpat $eventlist {
      if {[string match $eventpat $event]} {
        # This rule already exists
        return
      }
    }
  }
  dict lappend subscriptions $who $event
}

###
# topic: 5f74cfd01735fb1a90705a5f74f6cd8f
###
proc ::tool::event::unsubscribe {self args} {
  upvar #0 ::tool::object_subscribe($self) subscriptions
  if {![info exists subscriptions]} {
    return
  }  
  switch [llength $args] {
    1 {
      set event [lindex $args 0]
      if {$event eq "*"} {
        # Shortcut, if the 
        set subscriptions {}
      } else {
        set newlist {}
        foreach {objpat eventlist} $subscriptions {
          foreach eventpat $eventlist {
            if {[string match $event $eventpat]} continue
            dict lappend newlist $objpat $eventpat
          }
        }
        set subscriptions $newlist
      }
    }
    2 {
      set who [lindex $args 0]
      set event [lindex $args 1]
      if {$who eq "*" && $event eq "*"} {
        set subscriptions {}
      } else {
        set newlist {}
        foreach {objpat eventlist} $subscriptions {
          if {[string match $who $objpat]} {
            foreach eventpat $eventlist {
              if {[string match $event $eventpat]} continue
              dict lappend newlist $objpat $eventpat
            }
          }
        }
        set subscriptions $newlist
      }
    }
  }
}

::tool::define ::tool::object {
  ###
  # topic: 20b4a97617b2b969b96997e7b241a98a
  ###
  method event {submethod args} {
    ::tool::event::$submethod [self] {*}$args
  }
}

###
# topic: 37e7bd0be3ca7297996da2abdf5a85c7
# description: The event manager for Tool
###
namespace eval ::tool::event {
  variable nextevent {}
  variable nexteventtime 0
}


###
# END: event.tcl
###
###
# START: pipeline.tcl
###
::namespace eval ::tool::signal {}
::namespace eval ::tao {}

# Provide a backward compatible hook
proc ::tool::main {} {
  ::cron::main
}

proc ::tool::do_events {} {
  ::cron::do_events
}

proc ::tao::do_events {} {
  ::cron::do_events
}

proc ::tao::main {} {
  ::cron::main
}


package provide tool::pipeline 0.1


###
# END: pipeline.tcl
###
###
# START: coroutine.tcl
###
proc ::tool::define::coroutine {name corobody} {
  set class [current_class]
  ::oo::meta::info $class set method_ensemble ${name} _preamble: [list {} [string map [list %coroname% $name] {
    my variable coro_queue coro_lock
    set coro %coroname%
    set coroname [info object namespace [self]]::%coroname%
  }]]
  ::oo::meta::info $class set method_ensemble ${name} coroutine: {{} {
    return $coroutine
  }}
  ::oo::meta::info $class set method_ensemble ${name} restart: {{} {
    # Don't allow a coroutine to kill itself
    if {[info coroutine] eq $coroname} return
    if {[info commands $coroname] ne {}} {
      rename $coroname {}
    }
    set coro_lock($coroname) 0
    ::coroutine $coroname {*}[namespace code [list my $coro main]]
    ::cron::object_coroutine [self] $coroname
  }}
  ::oo::meta::info $class set method_ensemble ${name} kill: {{} {
    # Don't allow a coroutine to kill itself
    if {[info coroutine] eq $coroname} return
    if {[info commands $coroname] ne {}} {
      rename $coroname {}
    }
  }}

  ::oo::meta::info $class set method_ensemble ${name} main: [list {} $corobody]

  ::oo::meta::info $class set method_ensemble ${name} clear: {{} {
    set coro_queue($coroname) {}
  }}
  ::oo::meta::info $class set method_ensemble ${name} next: {{eventvar} {
    upvar 1 [lindex $args 0] event
    if {![info exists coro_queue($coroname)]} {
      return 1
    }
    if {[llength $coro_queue($coroname)] == 0} {
      return 1
    }
    set event [lindex $coro_queue($coroname) 0]
    set coro_queue($coroname) [lrange $coro_queue($coroname) 1 end]
    return 0
  }}
  
  ::oo::meta::info $class set method_ensemble ${name} peek: {{eventvar} {
    upvar 1 [lindex $args 0] event
    if {![info exists coro_queue($coroname)]} {
      return 1
    }
    if {[llength $coro_queue($coroname)] == 0} {
      return 1
    }
    set event [lindex $coro_queue($coroname) 0]
    return 0
  }}

  ::oo::meta::info $class set method_ensemble ${name} running: {{} {
    if {[info commands $coroname] eq {}} {
      return 0
    }
    if {[::cron::task exists $coroname]} {
      set info [::cron::task info $coroname]
      if {[dict exists $info running]} {
        return [dict get $info running]
      }
    }
    return 0
  }}
  
  ::oo::meta::info $class set method_ensemble ${name} send: {args {
    lappend coro_queue($coroname) $args
    if {[info coroutine] eq $coroname} {
      return
    }
    if {[info commands $coroname] eq {}} {
      ::coroutine $coroname {*}[namespace code [list my $coro main]]
      ::cron::object_coroutine [self] $coroname
    }
    if {[info coroutine] eq {}} {
      ::cron::do_one_event $coroname
    } else {
      yield
    }
  }}
  ::oo::meta::info $class set method_ensemble ${name} default: {args {my [self method] send $method {*}$args}}

}

###
# END: coroutine.tcl
###
###
# START: organ.tcl
###
###
# A special class of objects that
# stores no meta data of its own
# Instead it vampires off of the master object
###
tool::class create ::tool::organelle {
  
  constructor {master} {
    my entangle $master
    set final_class [my select]
    if {[info commands $final_class] ne {}} {
      # Safe to switch class here, we haven't initialized anything
      oo::objdefine [self] class $final_class
    }
    my initialize
  }

  method entangle {master} {
    my graft master $master
    my forward meta $master meta
    foreach {stub organ} [$master organ] {
      my graft $stub $organ
    }
    foreach {methodname variable} [my meta branchget array_ensemble] {
      my forward $methodname $master $methodname
    }
  }
  
  method select {} {
    return {}
  }
}

###
# END: organ.tcl
###
###
# START: script.tcl
###
###
# Add configure by script facilities to TOOL
###
::tool::define ::tool::object {

  ###
  # Allows for a constructor to accept a psuedo-code
  # initialization script which exercise the object's methods
  # sans "my" in front of every command
  ###
  method Eval_Script script {
    set buffer {}
    set thisline {}
    foreach line [split $script \n] {
      append thisline $line
      if {![info complete $thisline]} {
        append thisline \n
        continue
      }
      set thisline [string trim $thisline]
      if {[string index $thisline 0] eq "#"} continue
      if {[string length $thisline]==0} continue
      if {[lindex $thisline 0] eq "my"} {
        # Line already calls out "my", accept verbatim
        append buffer $thisline \n
      } elseif {[string range $thisline 0 2] eq "::"} {
        # Fully qualified commands accepted verbatim
        append buffer $thisline \n
      } elseif {
        append buffer "my $thisline" \n
      }
      set thisline {}
    }
    eval $buffer
  }
}
###
# END: script.tcl
###

namespace eval ::tool {
  namespace export *
}

Added modules/tool/tool.test.































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
# tool.test - Copyright (c) 2015 Sean Woods
# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.6
testsNeedTcltest 2
testsNeed        TclOO 1


support {
    use oodialect/oodialect.tcl oo::dialect
    use dicttool/dicttool.tcl   dicttool
    use cron/cron.tcl           cron
    use oometa/oometa.tcl       oo::meta
    use sha1/sha1.tcl           sha1
}
testing {
    useLocal tool.tcl tool
}

# -------------------------------------------------------------------------

###
# Test the underlying components
###
::tool::event::subscribe ::BARNEY ::BETTY *
test tool-subscribe-001 {Test that tool subscribe inserts a pattern into the dictionary} {
  set ::tool::object_subscribe(::BARNEY)
} {::BETTY *}

test tool-notify-001 {Test the distribution list} {
  ::tool::event::Notification_list ::BETTY niceday
} ::BARNEY

::tool::event::subscribe ::BARNEY ::BETTY *
test tool-subscribe-002 {Test that tool subscribe inserts a pattern into the dictionary only once} {
  set ::tool::object_subscribe(::BARNEY)
} {::BETTY *}

::tool::event::subscribe ::BARNEY ::BETTY niceday
test tool-subscribe-002 {Test that tool subscribe will not add a more specific pattern if a general one already exists} {
  set ::tool::object_subscribe(::BARNEY)
} {::BETTY *}

test tool-notify-002 {Test the distribution list} {
  ::tool::event::Notification_list ::BETTY niceday
} ::BARNEY

::tool::event::subscribe ::BARNEY * caring
test tool-subscribe-003 {Test that tool subscribe inserts a global pattern} {
  set ::tool::object_subscribe(::BARNEY)
} {::BETTY * * caring}

::tool::event::subscribe ::BARNEY * sharing
test tool-subscribe-004 {Test that tool subscribe inserts a global pattern} {
  set ::tool::object_subscribe(::BARNEY)
} {::BETTY * * {caring sharing}}

::tool::event::subscribe ::BARNEY ::FRED sharing
::tool::event::unsubscribe ::BARNEY * sharing
test tool-subscribe-005 {Test that tool unsubscribe removes a global pattern} {
  set ::tool::object_subscribe(::BARNEY)
} {::BETTY * * caring}

::tool::event::subscribe ::BARNEY ::FRED sharing
::tool::event::subscribe ::BARNEY ::FRED niceday
::tool::event::subscribe ::BETTY ::FRED niceday

test tool-subscribe-005 {Test that tool unsubscribe removes a global pattern} {
  set ::tool::object_subscribe(::BARNEY)
} {::BETTY * * caring ::FRED {sharing niceday}}

test tool-notify-002 {Test the distribution list} {
  ::tool::event::Notification_list ::BETTY caring
} ::BARNEY

test tool-notify-002 {Test the distribution list} {
  lsort -dictionary [::tool::event::Notification_list ::FRED niceday]
} {::BARNEY ::BETTY}

# Test that destroy auto-cleans up the event list
::tool::object_destroy ::BARNEY
test tool-destroy-001 {Test that destroy auto-cleans up the event list} {
  info exists ::tool::object_subscribe(::BARNEY)
} 0

# Start over
array unset ::tool::object_subscribe


tool::class create OptionClass {
  property color green
  property mass  1200kg
  option bodystyle {default: sedan}
  option master {class organ default ::noop}
}

tool::class create OptionClass2 {
  superclass OptionClass
  property mass  1400kg
  option color {default: blue}
}

OptionClass create ObjectOptionTest1 
OptionClass create ObjectOptionTest2 bodystyle wagon transmission standard
OptionClass2 create ObjectOptionTest3
OptionClass2 create ObjectOptionTest4 bodystyle SUV transmission cvt color white

###
# Property ignores options
###
test tool-options-001 {Simple property queries} {
  ObjectOptionTest1 meta cget color
} green

test tool-options-002 {Simple property queries} {
  ObjectOptionTest2 meta cget color
} green

test tool-options-003 {Simple property queries} {
  ObjectOptionTest3 meta cget color
} green

test tool-options-004 {Simple property queries} {
  ObjectOptionTest4 meta cget color
} green

###
# Cget consults the options
###
test tool-options-005 {Simple property queries} {
  ObjectOptionTest1 cget color
} green

test tool-options-006 {Simple property queries} {
  ObjectOptionTest2 cget color
} green

test tool-options-007 {Simple property queries} {
  ObjectOptionTest3 cget color
} blue

test tool-options-008 {Simple property queries} {
  ObjectOptionTest4 cget color
} white

###
# Tests with options in an object changing class
###
test tool-options-009 {Simple property queries} {
  ObjectOptionTest3 meta cget mass
} 1400kg

ObjectOptionTest3 morph OptionClass
# The option for color was already set. It should remain
test tool-options-010 {Simple property queries} {
  ObjectOptionTest3 cget color
} blue
# The "color" property on the other hand should revert
test tool-options-011 {Simple property queries} {
  ObjectOptionTest3 meta cget color
} green
# The "mass" property on the other hand should revert
test tool-options-012 {Simple property queries} {
  ObjectOptionTest3 meta cget mass
} 1200kg

# Change a OptionClass to a OptionClass2

test tool-options-013 {Simple property queries} {
  ObjectOptionTest2 meta cget mass
} 1200kg

ObjectOptionTest2 morph OptionClass2
# When entering OptionClass2, the object will get any new options
test tool-options-014 {Simple property queries} {
  ObjectOptionTest2 cget color
} blue

test tool-options-015 {Simple property queries} {
  ObjectOptionTest2 meta cget mass
} 1400kg

# When changing back, the set option remains
ObjectOptionTest2 morph OptionClass
test tool-options-016 {Simple property queries} {
  ObjectOptionTest2 cget color
} blue

test tool-options-017 {Simple property queries} {
  ObjectOptionTest2 meta cget mass
} 1200kg


tool::class create ArrayEnsembleClass {
  # Burned in defaults
  meta branchset define {
    color: pink
  }

  array_ensemble define define {
    initialize {
      foo bar
    }
    custom {
      return custom
    }
    true {
      return true
    }
    false {
      return false
    }
  }
}

ArrayEnsembleClass create ArrayEnsembleObject

test tool-ensemble-001 {Test Array Ensemble} {
  ArrayEnsembleObject define true
} true
test tool-ensemble-002 {Test Array Ensemble} {
  ArrayEnsembleObject define false
} false
test tool-ensemble-003 {Test Array Ensemble retrieve initial value} {
  ArrayEnsembleObject define get foo
} bar
test tool-ensemble-004 {Test Array Ensemble Store a value} {
  ArrayEnsembleObject define set cc /usr/bin/cc
  ArrayEnsembleObject define get cc
} /usr/bin/cc

test tool-ensemble-005 {Test array add} {
  ArrayEnsembleObject define add path /bin
  ArrayEnsembleObject define get path
} /bin

test tool-ensemble-005 {Test array add} {
  ArrayEnsembleObject define add path /usr/bin
  ArrayEnsembleObject define get path
} {/bin /usr/bin}

test tool-ensemble-006 {Test array add (again)} {
  ArrayEnsembleObject define add path /usr/bin
  ArrayEnsembleObject define get path
} {/bin /usr/bin}


test tool-ensemble-007 {Test array lappend} {
  ArrayEnsembleObject define lappend path /usr/bin
  ArrayEnsembleObject define get path
} {/bin /usr/bin /usr/bin}

test tool-ensemble-008 {Test array remove} {
  ArrayEnsembleObject define remove path /usr/bin
  ArrayEnsembleObject define get path
} {/bin}

test tool-ensemble-009 {Test array exists} {
  ArrayEnsembleObject define exists counter
} 0

test tool-ensemble-010 {Test array incr} {
  ArrayEnsembleObject define incr counter
  ArrayEnsembleObject define get counter
} 1

test tool-ensemble-011 {Test array incr} {
  ArrayEnsembleObject define incr counter
  ArrayEnsembleObject define get counter
} 2

test tool-ensemble-012 {Test array exists} {
  ArrayEnsembleObject define exists counter
} 1

test tool-ensemble-013 {Test array reset} {
  ArrayEnsembleObject define reset
  lsort -stride 2 [ArrayEnsembleObject define dump]
} {color pink foo bar}

tool::class create DictEnsembleClass {
  # Burned in defaults
  meta branchset define {
    color: pink
  }

  dict_ensemble define define {
    initialize {
      foo bar
    }
    custom {
      return custom
    }
    true {
      return true
    }
    false {
      return false
    }
  }
}

DictEnsembleClass create DictEnsembleObject

test tool-ensemble-001 {Test Array Ensemble} {
  DictEnsembleObject define true
} true
test tool-ensemble-002 {Test Array Ensemble} {
  DictEnsembleObject define false
} false
test tool-ensemble-003 {Test Array Ensemble retrieve initial value} {
  DictEnsembleObject define get foo
} bar
test tool-ensemble-004 {Test Array Ensemble Store a value} {
  DictEnsembleObject define set cc /usr/bin/cc
  DictEnsembleObject define get cc
} /usr/bin/cc

test tool-ensemble-005 {Test array add} {
  DictEnsembleObject define add path /bin
  DictEnsembleObject define get path
} /bin

test tool-ensemble-005 {Test array add} {
  DictEnsembleObject define add path /usr/bin
  DictEnsembleObject define get path
} {/bin /usr/bin}

test tool-ensemble-006 {Test array add (again)} {
  DictEnsembleObject define add path /usr/bin
  DictEnsembleObject define get path
} {/bin /usr/bin}


test tool-ensemble-007 {Test array lappend} {
  DictEnsembleObject define lappend path /usr/bin
  DictEnsembleObject define get path
} {/bin /usr/bin /usr/bin}

test tool-ensemble-008 {Test array remove} {
  DictEnsembleObject define remove path /usr/bin
  DictEnsembleObject define get path
} {/bin}

test tool-ensemble-009 {Test array exists} {
  DictEnsembleObject define exists counter
} 0

test tool-ensemble-010 {Test array incr} {
  DictEnsembleObject define incr counter
  DictEnsembleObject define get counter
} 1

test tool-ensemble-011 {Test array incr} {
  DictEnsembleObject define incr counter
  DictEnsembleObject define get counter
} 2

test tool-ensemble-012 {Test array exists} {
  DictEnsembleObject define exists counter
} 1

test tool-ensemble-013 {Test array reset} {
  DictEnsembleObject define reset
  lsort -stride 2 [DictEnsembleObject define dump]
} {color pink foo bar}




test tool-option_class-001 {Test option class} {
  ObjectOptionTest1 meta get option master
} {default: ::noop class: organ widget: label set-command: {my graft %field% %value%} get-command: {my organ %field%}}

proc GNDN args {
  return $args
}

ObjectOptionTest1 configure master GNDN
test tool-option_class-002 {Test option class} {
  ObjectOptionTest1 organ master
} GNDN

test tool-option_class-003 {Test option class} {
  ObjectOptionTest1 <master> puts FOO
} {puts FOO}

OptionClass2 create ObjectOptionTest5 bodystyle SUV transmission cvt color white master GNDN

test tool-option_class-002 {Test option class} {
  ObjectOptionTest5 organ master
} GNDN

test tool-option_class-003 {Test option class} {
  ObjectOptionTest5 <master> puts FOO
} {puts FOO}

###
# Second round of testing
# Make sure the various and sundry ways to generate
# dynamic methods follow through morphs, mixins,
# and class method definitions
###

tool::class create WidgetClass {
  class_method unknown args {
    set tkpath [lindex $args 0]
    if {[string index $tkpath 0] eq "."} {
      set obj [my new $tkpath {*}[lrange $args 1 end]]
      $obj tkalias $tkpath
      return $tkpath
    }
    next {*}$args
  }
  
  constructor {TkPath args} {
    my variable hull
    set hull $TkPath
    my graft hull $TkPath
  }
    
  method tkalias tkname {
    set oldname $tkname
    my variable tkalias
    set tkalias $tkname
    set self [self]
    set hullwidget [::info object namespace $self]::tkwidget
    my graft tkwidget $hullwidget
    #rename ::$tkalias $hullwidget
    my graft hullwidget $hullwidget
    ::tool::object_rename [self] ::$tkalias
    #my Hull_Bind $tkname
    return $hullwidget
  }
}

test tool-class-method-001 {Test Tk style creator} {
  WidgetClass .foo
  .foo organ hull
} {.foo}

tool::class create WidgetNewClass {
  superclass WidgetClass
}

test tool-class-method-002 {Test Tk style creator inherited by morph} {
  WidgetNewClass .bar
  .bar organ hull
} {.bar}

tool::class create DummyClass {
  method i_am_here {} {
    return DummyClass
  }
}


tool::class create OrganClass {
  option db {class organ default ::noop}
  constructor args {
    my config set $args
  }
}
DummyClass create ::DbObj
OrganClass create OrganObject db ::DbObj
test tool-constructor-args-001 {Test that organs passed as options map correctly} {
  OrganObject organ db
} {::DbObj} 
test tool-constructor-args-002 {Test that organs passed as options map correctly} {
  OrganObject cget db
} {::DbObj}

tool::object create MorphOrganObject#1
tool::object create MorphOrganObject#2
MorphOrganObject#2 graft db ::DbObj

MorphOrganObject#1 morph OrganClass
test tool-constructor-args-003 {Test that a default for an organ option is applied after a morph} {
  MorphOrganObject#1  organ db
} {::noop}

MorphOrganObject#2 morph OrganClass
test tool-constructor-args-004 {Test that a default for an organ option is NOT applied if the graft exists following a morph} {
  MorphOrganObject#2  organ db
} {::DbObj}

tool::object create MorphOrganObject#3
tool::object create MorphOrganObject#4
MorphOrganObject#4 graft db ::DbObj
MorphOrganObject#3 mixin OrganClass
test tool-constructor-args-005 {Test that a default for an organ option is applied during a mixin} {
  MorphOrganObject#3  organ db
} {::noop}

MorphOrganObject#4 mixin OrganClass
test tool-constructor-args-006 {Test that a default for an organ option is NOT applied if the graft exists during a mixin} {
  MorphOrganObject#4  organ db
} {::DbObj}

###
# Test ensemble inheritence
###
tool::define NestedClassA {
  method do::family {
    return [self class]
  }
  method do::something {
    return A
  }
  method do::whop {
    return A
  }
}
tool::define NestedClassB {
  superclass NestedClassA
  method do::family {
    set r [next family]
    lappend r [self class]
    return $r
  }
  method do::whop {
    return B
  }
}
tool::define NestedClassC {
  superclass NestedClassB

  method do::somethingelse {
    return C
  }
}
tool::define NestedClassD {
  superclass NestedClassB

  method do::somethingelse {
    return D
  }
}

tool::define NestedClassE {
  superclass NestedClassD NestedClassC
}

tool::define NestedClassF {
  superclass NestedClassC NestedClassD
}

NestedClassC create NestedObjectC

test tool-ensemble-001 {Test that an ensemble can access [next] even if no object of the ancestor class have been instantiated} {
  NestedObjectC do family
} {::NestedClassA ::NestedClassB ::NestedClassC}

test tool-ensemble-002 {Test that a later ensemble definition trumps a more primitive one} {
  NestedObjectC do whop
} {B}
test tool-ensemble-003 {Test that an ensemble definitions in an ancestor carry over} {
  NestedObjectC do something
} {A}

NestedClassE create NestedObjectE
NestedClassF create NestedObjectF


test tool-ensemble-004 {Test that ensembles follow the same rules for inheritance as methods} {
  NestedObjectE do somethingelse
} {D}

test tool-ensemble-005 {Test that ensembles follow the same rules for inheritance as methods} {
  NestedObjectF do somethingelse
} {C}

###
# Set of tests to exercise the mixinmap system
###
tool::define MixinMainClass {
  variable mainvar unchanged
  
  method test::which {} {
    my variable mainvar
    return $mainvar
  }
  
  method test::main args {
    puts [list this is main $method $args]
  }

}

tool::define MixinTool {
  variable toolvar unchanged.mixin
  meta set mixin unmap-script: {
my test untool $class
  }
  meta set mixin map-script: {
my test tool $class
  }
  meta set mixin name: {Generic Tool}
  
  method test::untool class { 
    my variable toolvar mainvar
    set mainvar {}
    set toolvar {} 
  }
  
  method test::tool class {
    my variable toolvar mainvar
    set mainvar [$class meta get mixin name:] 
    set toolvar [$class meta get mixin name:] 
  }
}

tool::define MixinToolA {
  superclass MixinTool
  meta set mixin name: {Tool A}
}

tool::define MixinToolB {
  superclass MixinTool
  meta set mixin name: {Tool B}

  method test_newfunc {} {
    return "B"
  }
}

MixinMainClass create mixintest

test tool-mixinmap-001 {Test object prior to mixins} {
  mixintest test which
} {unchanged}

mixintest mixinmap tool MixinToolA
test tool-mixinmap-002 {Test mixin map script ran} {
  mixintest test which
} {Tool A}

mixintest mixinmap tool MixinToolB
test tool-mixinmap-003 {Test mixin map script ran} {
  mixintest test which
} {Tool B}

test tool-mixinmap-003 {Test mixin map script ran} {
  mixintest test_newfunc
} {B}

mixintest mixinmap tool {}
test tool-mixinmap-001 {Test object prior to mixins} {
  mixintest test which
} {}

###
# Coroutine tests
###
tool::define coro_example {
  
  dict_ensemble coro_a_info coro_a_info {
    initialize {
      restart 0
      phase 0
      loop  0
      event 0
      idle  0
    }
  }
  
  coroutine coro_a {
    my coro_a_info merge {
      phase 0
      loop  0
      event 0
      idle  0
    }
    yield [info coroutine]
    while 1 {
      my coro_a_info incr phase
      my coro_a_info set  loop 0
      while 1 {
        if {[my $coro next event]} {
          my coro_a_info incr idle
          yield
          continue
        }
        my coro_a_info set last_event $event
        my coro_a_info incr loop
        my coro_a_info incr event
        switch [lindex $event 0] {
          phase {
            break
          }
          quit {
            return
          }
          b {
            my coro_b send [lrange $event 1 end]
          }
        }
      }
    }
  }
  
  dict_ensemble coro_b_info coro_b_info {
    initialize {
      restart 0
      phase 0
      loop  0
      event 0
      idle  0
    }
  }
  
  coroutine coro_b {
    my coro_b_info merge {
      phase 0
      loop  0
      event 0
      idle  0
    }
    yield [info coroutine]

    while 1 {
      my coro_b_info incr phase
      my coro_b_info set  loop 0
      while 1 {
        if {[my $coro next event]} {
          my coro_b_info incr idle
          yield
          continue
        }
        my coro_b_info incr loop
        my coro_b_info incr event
        switch [lindex $event 0] {
          phase break
          quit return
          a {
            my coro_a [lrange $event 1 end]
          }
        }
      }
    }
  }
  

  dict_ensemble coro_yodawg_info coro_yodawg_info {
    initialize {
      restart 0
      phase 0
      loop  0
      event 0
      idle  0
      yodawg  0
    }
  }
  
  coroutine coro_yodawg {
    my coro_yodawg_info merge {
      phase 0
      loop  0
      event 0
      idle  0
      yodawg  0
      iloop 0
    }
    yield [info coroutine]

    while 1 {
      my coro_yodawg_info incr phase
      my coro_yodawg_info set  loop 0
      while 1 {
        if {[my $coro next event]} {
          my coro_yodawg_info incr idle
          yield
          continue
        }
        my coro_yodawg_info set last_event $event
        my coro_yodawg_info incr loop
        my coro_yodawg_info incr event
        switch [lindex $event 0] {
          phase break
          quit {
            return
          }
          yodawg {
            my coro_yodawg_info incr yodawg
            if {[my coro_yodawg_info get yodawg] <32} {
              my coro_yodawg yodawg
              yield
            }
          }
          iloop {
            my coro_yodawg_info incr iloop
          }
        }
      }
    }
  }
}

set obj [coro_example new]
$obj coro_a none
test tool-coroutine-001-00 {Test coroutine } {
  $obj coro_a_info get restart
} 0
test tool-coroutine-001-01 {Test coroutine } {
  $obj coro_a_info get loop
} 1
$obj coro_a none
test tool-coroutine-001-02 {Test coroutine } {
  $obj coro_a_info get loop
} 2
$obj coro_a none
test tool-coroutine-001-03 {Test coroutine } {
  $obj coro_a_info get loop
} 3
$obj coro_a phase
test tool-coroutine-002-01 {Test coroutine } {
  $obj coro_a_info get loop
} 0
test tool-coroutine-002-02 {Test coroutine } {
  $obj coro_a_info get phase
} 2

###
# Start both coroutines over
$obj coro_a restart
$obj coro_b restart

test tool-coroutine-003-01-A {Test coroutine } {
  $obj coro_a_info get phase
} 0
test tool-coroutine-003-01-B {Test coroutine } {
  $obj coro_a_info get loop
} 0
test tool-coroutine-003-01-C {Test coroutine } {
  $obj coro_a_info get phase
} 0
test tool-coroutine-003-01-D {Test coroutine } {
  $obj coro_b_info get loop
} 0


$obj coro_a b
###
# Test coroutines calling coroutines
test tool-coroutine-003-02-A {Test coroutine } {
  $obj coro_a_info get loop
} 1
test tool-coroutine-003-02-B {Test coroutine } {
  $obj coro_b_info get loop
} 1

$obj coro_b a
###
# Test coroutines calling coroutines
# Note: Each call to each other coroutine can only happen
# once per "send"
###
test tool-coroutine-003-03-A {Test coroutine } {
  $obj coro_a_info get loop
} 1
test tool-coroutine-003-03-B {Test coroutine } {
  $obj coro_b_info get loop
} 2

###
# Rig the coroutine to call itself back from the other coroutine
###
$obj coro_b a b
###
# Test coroutines calling coroutines
test tool-coroutine-003-04-A {Test coroutine } {
  $obj coro_a_info get loop
} 2
test tool-coroutine-003-04-B {Test coroutine } {
  $obj coro_b_info get loop
} 3

# We should see A update in the background
$obj coro_b loop
test tool-coroutine-003-05-A {Test coroutine } {
  $obj coro_a_info get loop
} 3
test tool-coroutine-003-05-B {Test coroutine } {
  $obj coro_b_info get loop
} 5

# Now only B advances
$obj coro_b loop
test tool-coroutine-003-05-A {Test coroutine } {
  $obj coro_a_info get loop
} 3
test tool-coroutine-003-05-B {Test coroutine } {
  $obj coro_b_info get loop
} 6

# Now only A advances
$obj coro_a loop
test tool-coroutine-003-06-A {Test coroutine } {
  $obj coro_a_info get loop
} 4
test tool-coroutine-003-06-B {Test coroutine } {
  $obj coro_b_info get loop
} 6

###
# Test a malformed coroutine that calls itself
# The safety mechanism should allow the event to re-schedule itself
# but only once per call, and only execute once per call
###
test tool-coroutine-yodawg-00 {Test coroutine - yodawg } {
  $obj coro_yodawg running
} 0

$obj coro_yodawg yodawg
test tool-coroutine-yodawg-01 {Test coroutine - yodawg } {
  $obj coro_yodawg_info get yodawg
} 1
$obj coro_yodawg
test tool-coroutine-yodawg-02 {Test coroutine - yodawg } {
  $obj coro_yodawg_info get yodawg
} 2
$obj coro_yodawg yodawg
$obj coro_yodawg yodawg
test tool-coroutine-yodawg-03 {Test coroutine - yodawg } {
  $obj coro_yodawg_info get yodawg
} 4
for {set x 1} {$x < 32} {incr x} {
  $obj coro_yodawg iloop
  set a [$obj coro_yodawg_info get yodawg]
  set levent [$obj coro_yodawg_info get last_event]
  set iloop [$obj coro_yodawg_info get iloop]
  if {$a > 32} break
  test tool-coroutine-yodawg-03-yd-$x {Test coroutine - yodawg } {
    set a
  } [expr {4+$x}]
  test tool-coroutine-yodawg-03-le-$x {Test coroutine - yodawg } {
    set levent
  } yodawg
  # The iloop should *ALSO* be running side-by-side with the yodawg
  # However, not until the first three yodawg events are processed
  # in the queue
  if {$x > 3} {
    test tool-coroutine-yodawg-03-il-$x {Test coroutine - yodawg } {
      set iloop
    } [expr {$x-3}]
  }
}
###
# With the yodawgs resolved we should now
# be processing events in order once more
# Add one more event
#
# NOTE the lagging iloop events do catch up
###
$obj coro_yodawg end
test tool-coroutine-yodawg-03-iloop-count {Test coroutine - yodawg } {
  $obj coro_yodawg_info get iloop
} $x
test tool-coroutine-yodawg-03-endevent {Test coroutine - yodawg } {
  $obj coro_yodawg_info get last_event
} end

# -------------------------------------------------------------------------


testsuiteCleanup

# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:

Added modules/tool/tool_dict_ensemble.man.





































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin tool::dict_ensemble n 0.4.2]
[keywords TOOL]
[copyright {2015 Sean Woods <yoda@etoyoc.com>}]
[moddesc   {Standardized OO Framework for development}]
[titledesc {Dictionary Tools}]
[category Utility]
[keywords TclOO]
[keywords TOOL]
[require tool [opt 0.4.2]]
[description]
[para]
The [cmd dict_ensemble] command is a keyword added by [package tool]. It defines
a public variable (stored as a dict), and an access function to manipulated and
access the values stored in that dict.
[list_begin definitions]

[call [emph object] [arg ensemble] [cmd add] [arg field]]] [arg value] [arg {value ...}]]

Adds elements to a list maintained with the [arg field] leaf of the dict maintained
my this ensemble.


Declares a variable [arg name] which will be initialized as an array, populated with [arg contents] for objects of this class, as well as any
objects for classes which are descendents of this class.

[list_end]

[section AUTHORS]
Sean Woods

[vset CATEGORY tool]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

Added modules/uuid/ChangeLog.





























































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
2013-02-01  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.15 ========================
	* 

2012-11-19  Andreas Kupries  <andreask@activestate.com>

	* uuid.tcl (::uuid::generate_tcl): Accepted patch by Sean Woods
	* uuid.man: caching the host information part of the uuid. Avoids
	* pkgIndex.tcl: hammering the network stack for hostname and
	  related information. Bumped version to 1.0.2.

2011-12-13  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.14 ========================
	* 

2011-01-24  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.13 ========================
	* 

2009-12-07  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.12 ========================
	* 

2008-12-12  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.11.1 ========================
	* 

2008-10-16  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.11 ========================
	* 

2007-09-12  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.10 ========================
	* 

2007-03-21  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* uuid.man: Fixed all warnings due to use of now deprecated
	  commands. Added a section about how to give feedback.

2006-10-03  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.9 ========================
	* 

2006-01-26  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* uuid.test: More boilerplate simplified via use of test support.

2006-01-19  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* uuid.test: Hooked into the new common test support code.

2005-10-06  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.8 ========================
	* 

2005-10-05  Pat Thoyts  <patthoyts@users.sourceforge.net>

	* uuid.test:  Ensure we test all implementations.
	* uuid.tcl:   Updated critcl code to work with msvc.

2005-09-05  Pat Thoyts  <patthoyts@users.sourceforge.net>

	* uuid.tcl: Bug #1150714 - opening a server socket may raise a
	warning message box on WinXP firewall. Instead call the ipconfig
	utility and use the result on windows.

2005-02-10  Pat Thoyts  <patthoyts@users.sourceforge.net>

	* uuid.tcl: Fixed missing include in the critcl code.

2004-10-05  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.7 ========================
	* 

2004-07-12  Pat Thoyts  <patthoyts@users.sourceforge.net>

	* uuid.tcl:   Added a critcl version for generating uuids on Win32.

2004-07-08  Pat Thoyts  <patthoyts@users.sourceforge.net>

	* uuid.tcl:   Changed uuid compare to uuid equal (bug #987305)
	* uuid.man:
	* uuid.test:
	
	* uuid.tcl:   Package for UUID generation and comparison.
	* uuid.test:
	* uuid.man:
	

Added modules/uuid/pkgIndex.tcl.





>
>
1
2
if {![package vsatisfies [package provide Tcl] 8.5]} {return}
package ifneeded uuid 1.0.6 [list source [file join $dir uuid.tcl]]

Added modules/uuid/uuid.man.















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
[vset VERSION 1.0.6]
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin uuid n [vset VERSION]]
[keywords GUID]
[keywords UUID]
[moddesc {uuid}]
[copyright {2004, Pat Thoyts <patthoyts@users.sourceforge.net>}]
[titledesc {UUID generation and comparison}]
[category  {Hashes, checksums, and encryption}]
[require Tcl 8.5]
[require uuid [opt [vset VERSION]]]
[description]
[para]

This package provides a generator of universally unique identifiers
(UUID) also known as globally unique identifiers (GUID). This
implementation follows the draft specification from (1) although this
is actually an expired draft document.

[section {COMMANDS}]

[list_begin definitions]

[call [cmd "::uuid::uuid generate"]]

Creates a type 4 uuid by MD5 hashing a number of bits of variant data
including the time and hostname.
Returns the string representation of the new uuid.

[call [cmd "::uuid::uuid equal"] [arg "id1"] [arg "id2"]]

Compares two uuids and returns true if both arguments are the same uuid.

[list_end]

[section {EXAMPLES}]

[example {
% uuid::uuid generate
b12dc22c-5c36-41d2-57da-e29d0ef5839c
}]

[section {REFERENCES}]

[list_begin enumerated]

[enum]
    Paul J. Leach, "UUIDs and GUIDs", February 1998.
    ([uri http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt])

[list_end]

[vset CATEGORY uuid]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

Added modules/uuid/uuid.tcl.











































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# UUIDs are 128 bit values that attempt to be unique in time and space.
#
# Reference:
#   http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt
#
# uuid: scheme:
# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html
#
# Usage: uuid::uuid generate
#        uuid::uuid equal $idA $idB

package require Tcl 8.5

namespace eval uuid {
    variable accel
    array set accel {critcl 0}

    namespace export uuid

    variable uid
    if {![info exists uid]} {
        set uid 1
    }

    proc K {a b} {set a}
}

###
# Optimization
# Caches machine info after the first pass
###

proc ::uuid::generate_tcl_machinfo {} {
  variable machinfo
  if {[info exists machinfo]} {
    return $machinfo
  }
  lappend machinfo [clock seconds]; # timestamp
  lappend machinfo [clock clicks];  # system incrementing counter
  lappend machinfo [info hostname]; # spatial unique id (poor)
  lappend machinfo [pid];           # additional entropy
  lappend machinfo [array get ::tcl_platform]

  ###
  # If we have /dev/urandom just stream 128 bits from that
  ###
  if {[file exists /dev/urandom]} {
    set fin [open /dev/urandom r]
    set machinfo [binary encode base64 [read $fin 128]]
    close $fin
  } elseif {[catch {package require nettool}]} {
    # More spatial information -- better than hostname.
    # bug 1150714: opening a server socket may raise a warning messagebox
    #   with WinXP firewall, using ipconfig will return all IP addresses
    #   including ipv6 ones if available. ipconfig is OK on win98+
    if {[string equal $::tcl_platform(platform) "windows"]} {
      catch {exec ipconfig} config
      lappend machinfo $config
    } else {
      catch {
          set s [socket -server void -myaddr [info hostname] 0]
          K [fconfigure $s -sockname] [close $s]
      } r
      lappend machinfo $r
    }

    if {[package provide Tk] != {}} {
      lappend machinfo [winfo pointerxy .]
      lappend machinfo [winfo id .]
    }
  } else {
    ###
    # If the nettool package works on this platform
    # use the stream of hardware ids from it
    ###
    lappend machinfo {*}[::nettool::hwid_list]
  }
  return $machinfo
}

# Generates a binary UUID as per the draft spec. We generate a pseudo-random
# type uuid (type 4). See section 3.4
#
proc ::uuid::generate_tcl {} {
    package require md5 2
    variable uid

    set tok [md5::MD5Init]
    md5::MD5Update $tok [incr uid];      # package incrementing counter
    foreach string [generate_tcl_machinfo] {
      md5::MD5Update $tok $string
    }
    set r [md5::MD5Final $tok]
    binary scan $r c* r

    # 3.4: set uuid versioning fields
    lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}]
    lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}]

    return [binary format c* $r]
}

if {[string equal $tcl_platform(platform) "windows"]
        && [package provide critcl] != {}} {
    namespace eval uuid {
        critcl::ccode {
            #define WIN32_LEAN_AND_MEAN
            #define STRICT
            #include <windows.h>
            #include <ole2.h>
            typedef long (__stdcall *LPFNUUIDCREATE)(UUID *);
            typedef const unsigned char cu_char;
        }
        critcl::cproc generate_c {Tcl_Interp* interp} ok {
            HRESULT hr = S_OK;
            int r = TCL_OK;
            UUID uuid = {0};
            HMODULE hLib;
            LPFNUUIDCREATE lpfnUuidCreate = NULL;
            hLib = LoadLibraryA(("rpcrt4.dll"));
            if (hLib)
                lpfnUuidCreate = (LPFNUUIDCREATE)
                    GetProcAddress(hLib, "UuidCreate");
            if (lpfnUuidCreate) {
                Tcl_Obj *obj;
                lpfnUuidCreate(&uuid);
                obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid));
                Tcl_SetObjResult(interp, obj);
            } else {
                Tcl_SetResult(interp, "error: failed to create a guid",
                              TCL_STATIC);
                r = TCL_ERROR;
            }
            return r;
        }
    }
}

# Convert a binary uuid into its string representation.
#
proc ::uuid::tostring {uuid} {
    binary scan $uuid H* s
    foreach {a b} {0 7 8 11 12 15 16 19 20 end} {
        append r [string range $s $a $b] -
    }
    return [string tolower [string trimright $r -]]
}

# Convert a string representation of a uuid into its binary format.
#
proc ::uuid::fromstring {uuid} {
    return [binary format H* [string map {- {}} $uuid]]
}

# Compare two uuids for equality.
#
proc ::uuid::equal {left right} {
    set l [fromstring $left]
    set r [fromstring $right]
    return [string equal $l $r]
}

# Call our generate uuid implementation
proc ::uuid::generate {} {
    variable accel
    if {$accel(critcl)} {
        return [generate_c]
    } else {
        return [generate_tcl]
    }
}

# uuid generate -> string rep of a new uuid
# uuid equal uuid1 uuid2
#
proc uuid::uuid {cmd args} {
    switch -exact -- $cmd {
        generate {
            if {[llength $args] != 0} {
                return -code error "wrong # args:\
                    should be \"uuid generate\""
            }
            return [tostring [generate]]
        }
        equal {
            if {[llength $args] != 2} {
                return -code error "wrong \# args:\
                    should be \"uuid equal uuid1 uuid2\""
            }
            return [eval [linsert $args 0 equal]]
        }
        default {
            return -code error "bad option \"$cmd\":\
                must be generate or equal"
        }
    }
}

# -------------------------------------------------------------------------

# LoadAccelerator --
#
#	This package can make use of a number of compiled extensions to
#	accelerate the digest computation. This procedure manages the
#	use of these extensions within the package. During normal usage
#	this should not be called, but the test package manipulates the
#	list of enabled accelerators.
#
proc ::uuid::LoadAccelerator {name} {
    variable accel
    set r 0
    switch -exact -- $name {
        critcl {
            if {![catch {package require tcllibc}]} {
                set r [expr {[info commands ::uuid::generate_c] != {}}]
            }
        }
        default {
            return -code error "invalid accelerator package:\
                must be one of [join [array names accel] {, }]"
        }
    }
    set accel($name) $r
}

# -------------------------------------------------------------------------

# Try and load a compiled extension to help.
namespace eval ::uuid {
    variable e {}
    foreach e {critcl} {
        if {[LoadAccelerator $e]} break
    }
    unset e
}

package provide uuid 1.0.6

# -------------------------------------------------------------------------
# Local variables:
#   mode: tcl
#   indent-tabs-mode: nil
# End:

Added modules/uuid/uuid.test.

































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
# uuid.test:  tests for the uuid package                       -*- tcl -*-
#
# $Id: uuid.test,v 1.6 2006/10/09 21:41:42 andreas_kupries Exp $

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.5
testsNeedTcltest 1.0

testing {
    useLocal uuid.tcl uuid
}

# -------------------------------------------------------------------------
# Handle multiple implementation testing
#

array set preserve [array get ::uuid::accel]

proc implementations {} {
    variable ::uuid::accel
    foreach {a v} [array get accel] {if {$v} {lappend r $a}}
    lappend r tcl; set r
}

proc select_implementation {impl} {
    variable ::uuid::accel
    foreach e [array names accel] { set accel($e) 0 }
    if {[string compare "tcl" $impl] != 0} {
        set accel($impl) 1
    }
}

proc reset_implementation {} {
    variable ::uuid::accel
    array set accel [array get ::preserve]
}

# -------------------------------------------------------------------------
# Setup any constraints
#

# -------------------------------------------------------------------------
# Now the package specific tests....
# -------------------------------------------------------------------------

if {[::uuid::LoadAccelerator critcl]} {
    puts "> critcl based"
}
puts "> pure Tcl"

# -------------------------------------------------------------------------

foreach impl [implementations] {
    select_implementation $impl

    test uuid-1.0-$impl "uuid requires args" {
        list [catch {uuid::uuid} msg]
    } {1}
    
    test uuid-1.1-$impl "uuid generate should create a 36 char string uuid" {
        list [catch {string length [uuid::uuid generate]} msg] $msg
    } {0 36}
    
    test uuid-1.2-$impl "uuid comparison of uuid with self should be true" {
        list [catch {
            set a [uuid::uuid generate]
            uuid::uuid equal $a $a
        } msg] $msg
    } {0 1}
    
    test uuid-1.3-$impl "uuid comparison of two different\
        uuids should be false" {
        list [catch {
            set a [uuid::uuid generate]
            set b [uuid::uuid generate]
            uuid::uuid equal $a $b
        } msg] $msg
    } {0 0}
    
    reset_implementation
}

# -------------------------------------------------------------------------

testsuiteCleanup

# -------------------------------------------------------------------------
# Local Variables:
#   mode: tcl
#   indent-tabs-mode: nil
# End: